From ba7bb7c48309771fe43eecf77bdc04b86dd042a7 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 18:10:26 +0000 Subject: [PATCH 01/30] Import Stafford 3.8 --- LeanPool.lean | 347 +++++ LeanPool/Stafford38.lean | 387 +++++ LeanPool/Stafford38/AlgebraicAnalysis.lean | 79 ++ .../AlgebraicAnalysis/Commutator.lean | 54 + .../AlgebraicAnalysis/CommutatorRiccati.lean | 158 +++ .../AlgebraicAnalysis/Derivation/Central.lean | 96 ++ .../AlgebraicAnalysis/Derivation/Escape.lean | 170 +++ .../DifferentialOperators/Basic.lean | 205 +++ .../CoordinateGeneration.lean | 399 ++++++ .../LocalizedPolynomialCommutant.lean | 97 ++ .../LocalizedPolynomialDerivations.lean | 231 +++ .../FieldTheory/FunctionField.lean | 70 + .../FiniteTaylorReconstruction.lean | 284 ++++ .../BaseLocalizationModuleComparison.lean | 124 ++ .../Module/BaseLocalizedKoszulPositivity.lean | 147 ++ .../Module/CommutingPolynomialAction.lean | 100 ++ .../Module/DenominatorTorsion.lean | 108 ++ .../Module/EndomorphismKernelSupport.lean | 63 + .../EndomorphismKernelSupportOverBase.lean | 65 + .../Module/EscapeAssembly.lean | 198 +++ .../AlgebraicAnalysis/Module/EscapeSpan.lean | 132 ++ .../Module/FilteredSchreyer.lean | 83 ++ .../Module/FilteredStrictness.lean | 81 ++ .../FilteredTwoTermBoundaryExhaustion.lean | 154 ++ .../FilteredTwoTermBoundaryNaturality.lean | 68 + .../Module/FilteredTwoTermPageActions.lean | 317 +++++ .../FilteredTwoTermPageEquivalences.lean | 226 +++ .../Module/FilteredTwoTermPages.lean | 186 +++ .../FilteredTwoTermSuccessorNaturality.lean | 101 ++ .../Module/FilteredTwoTermTotalActions.lean | 179 +++ .../Module/FilteredTwoTermTotalPages.lean | 191 +++ .../Module/FreeSummandInduction.lean | 75 + .../Module/HyperplaneRestriction.lean | 129 ++ .../LocalizedKernelCokernelEquivalences.lean | 95 ++ .../LocalizedMinimalSupportAvoidance.lean | 101 ++ .../MinimalPrimeFiniteLengthLocalization.lean | 220 +++ .../Module/MinimalSupportExistence.lean | 44 + .../MinimalSupportKernelCokernelLengths.lean | 88 ++ .../Module/MonicAnnihilatorFinite.lean | 70 + .../Module/PrincipalKoszulFiniteTorsion.lean | 114 ++ ...incipalKoszulMinimalSupportPositivity.lean | 65 + .../Module/PrincipalKoszulPositivity.lean | 323 +++++ .../PrincipalKoszulSupportOverBase.lean | 82 ++ .../AlgebraicAnalysis/Module/RankExact.lean | 137 ++ .../AlgebraicAnalysis/Module/RankTorsion.lean | 197 +++ .../Module/RightCoordinates.lean | 119 ++ .../AlgebraicAnalysis/Module/Splice.lean | 99 ++ .../Module/SplitLatticePresentation.lean | 94 ++ .../Module/StableTorsionResidualSupport.lean | 116 ++ .../AlgebraicAnalysis/Module/StablyFree.lean | 32 + .../Module/TorsionProjectiveImage.lean | 84 ++ .../Module/TriangularDenominator.lean | 128 ++ .../Module/TwoSimplicity.lean | 60 + .../Module/TwoTermPageLength.lean | 99 ++ .../Module/UniformBoundaryVanishing.lean | 133 ++ .../AlgebraicAnalysis/Module/Unimodular.lean | 147 ++ .../Ore/ActiveCoordinate.lean | 196 +++ .../AlgebraicAnalysis/Ore/Associativity.lean | 415 ++++++ .../AlgebraicAnalysis/Ore/IteratedPBW.lean | 146 ++ .../AlgebraicAnalysis/Ore/IteratedTower.lean | 218 +++ .../AlgebraicAnalysis/Ore/LeftPBW.lean | 91 ++ .../AlgebraicAnalysis/Ore/Localization.lean | 117 ++ .../Ore/LocalizationExtension.lean | 42 + .../Ore/PrincipalRightIdeal.lean | 353 +++++ .../AlgebraicAnalysis/Ore/RightDivision.lean | 1241 +++++++++++++++++ .../Ore/RightHilbertBasis.lean | 565 ++++++++ .../Ore/RightIntersection.lean | 55 + .../Ore/RightLocalization.lean | 78 ++ .../AlgebraicAnalysis/Ore/RightPBW.lean | 384 +++++ .../AlgebraicAnalysis/Ore/RightQuotient.lean | 269 ++++ .../AlgebraicAnalysis/Ore/Tower.lean | 192 +++ .../Polynomial/DistinguishedVariable.lean | 103 ++ .../RingTheory/TwoGeneratorIdentity.lean | 108 ++ LeanPool/Stafford38/FixedSourceSolution.lean | 38 + LeanPool/Stafford38/Solution.lean | 44 + LeanPool/Stafford38/Stafford38.lean | 21 + .../CanonicalSupportVanishingReduction.lean | 193 +++ .../ArtinianAdaptedBasisExistence.lean | 244 ++++ .../ArtinianAdaptedBasisTraceAdapter.lean | 353 +++++ .../ArtinianCoefficientField.lean | 103 ++ .../ArtinianEquation33TraceProducer.lean | 143 ++ .../ArtinianTriangularTrace.lean | 145 ++ .../AssociatedGradedFinite.lean | 84 ++ .../AssociatedGradedModule.lean | 386 +++++ .../BGab001CoefficientFieldTrace.lean | 370 +++++ .../BaseLocalizationModuleComparison.lean | 15 + .../BaseLocalizedKoszulPositivity.lean | 20 + .../Characteristic/BaseRelativePoisson.lean | 98 ++ .../Characteristic/BaseZeroSection.lean | 185 +++ .../CanonicalAxisAvoidanceConsumer.lean | 288 ++++ .../CanonicalAxisMonicInitialTop.lean | 215 +++ .../Characteristic/CanonicalBaseVariety.lean | 134 ++ .../Characteristic/CanonicalCertificate.lean | 63 + .../CanonicalFilteredGradedBridge.lean | 192 +++ .../CanonicalFilteredTwoTerm.lean | 158 +++ .../CanonicalGabberInvolutivityInterface.lean | 159 +++ ...CanonicalGradedTangentialEquivalences.lean | 181 +++ .../CanonicalKoszulContradiction.lean | 136 ++ .../CanonicalLaurentSymbolControl.lean | 218 +++ .../CanonicalMonicSaturation.lean | 424 ++++++ ...anonicalNoncharacteristicCancellation.lean | 231 +++ .../CanonicalNormalAxisSupport.lean | 165 +++ .../CanonicalNormalSymbolFiniteness.lean | 98 ++ .../CanonicalOldTangentialFiniteness.lean | 121 ++ .../CanonicalPageEulerInequality.lean | 70 + ...lResidueExtensionSymbolControlAdapter.lean | 248 ++++ ...CanonicalSupportAvoidanceFromCokernel.lean | 73 + .../CanonicalTangentialBoundaryMaps.lean | 67 + .../CanonicalTangentialPageOperators.lean | 272 ++++ .../CanonicalTangentialRingEquivalence.lean | 103 ++ .../CanonicalTangentialSuccessors.lean | 99 ++ .../CanonicalTangentialSymbolFiniteness.lean | 178 +++ .../CanonicalTangentialTotalAction.lean | 119 ++ ...nonicalTotalGradedActionCompatibility.lean | 395 ++++++ .../CanonicalTotalGradedBridge.lean | 227 +++ .../CanonicalUnitCoordinatePreimage.lean | 183 +++ .../CanonicalUnitPreimageFromInitialTop.lean | 206 +++ .../CommutingPolynomialAction.lean | 15 + .../ConcreteEquation33SourceMatrices.lean | 627 +++++++++ .../ConcreteInducedZAction.lean | 625 +++++++++ ...ConcreteLocalizedTwoBlockSpecialFibre.lean | 178 +++ .../ConcreteSquareZeroTraceData.lean | 131 ++ .../Characteristic/EmptySupportVanishing.lean | 114 ++ .../EndomorphismKernelSupport.lean | 15 + .../EndomorphismKernelSupportOverBase.lean | 16 + .../Characteristic/FilteredQuotient.lean | 435 ++++++ .../FilteredQuotientGraded.lean | 211 +++ .../Characteristic/FilteredQuotientRees.lean | 166 +++ .../FilteredQuotientReesAction.lean | 542 +++++++ .../FilteredQuotientReesExact.lean | 152 ++ .../FilteredQuotientSpecialFibre.lean | 58 + .../FilteredQuotientSupport.lean | 177 +++ .../FilteredQuotientTwoJet.lean | 732 ++++++++++ .../FilteredTwoTermBoundaryExhaustion.lean | 16 + .../FilteredTwoTermBoundaryNaturality.lean | 17 + .../FilteredTwoTermPageActions.lean | 16 + .../FilteredTwoTermPageEquivalences.lean | 16 + .../Characteristic/FilteredTwoTermPages.lean | 15 + .../FilteredTwoTermSuccessorNaturality.lean | 16 + .../FilteredTwoTermTotalActions.lean | 16 + .../FilteredTwoTermTotalPages.lean | 17 + .../Characteristic/FilteredVanishing.lean | 112 ++ .../Characteristic/GabberGlobalAssembly.lean | 232 +++ .../GeometricSupportDescent.lean | 219 +++ .../GeometricSupportScalarExtension.lean | 106 ++ .../Characteristic/HomogeneousChart.lean | 167 +++ .../Characteristic/HyperplaneRestriction.lean | 15 + .../Characteristic/InitialIdeal.lean | 338 +++++ .../InitialIdealHomogeneous.lean | 204 +++ .../Characteristic/LinearAction.lean | 108 ++ .../LocalizedHighPowerTwoBlockVanishing.lean | 131 ++ .../LocalizedKernelCokernelEquivalences.lean | 15 + .../LocalizedMinimalSupportAvoidance.lean | 15 + ...edOrderReesTwoJetSpecializationKernel.lean | 174 +++ ...izedSpecializationActionCompatibility.lean | 111 ++ .../LocalizedTwoBlockModuleExactness.lean | 124 ++ ...calizedTwoBlockPrincipalKernelDescent.lean | 179 +++ .../LocalizedTwoBlockQuotient.lean | 347 +++++ .../MinimalPrimeFiniteLengthLocalization.lean | 15 + .../Characteristic/MinimalPrimePoisson.lean | 60 + .../MinimalSupportExistence.lean | 15 + .../MinimalSupportKernelCokernelLengths.lean | 17 + .../MonicAnnihilatorFinite.lean | 15 + .../NoncharacteristicMinimalPrime.lean | 149 ++ .../NormalSymbolPolynomial.lean | 114 ++ .../Characteristic/OrderReesTwoJet.lean | 343 +++++ .../OrderReesTwoJetBracket.lean | 280 ++++ .../OrderReesTwoJetSpecializationKernel.lean | 166 +++ .../Stafford38/Characteristic/Polynomial.lean | 53 + .../PostScalarExtensionPoisson.lean | 205 +++ .../PrincipalKoszulFiniteTorsion.lean | 16 + ...incipalKoszulMinimalSupportPositivity.lean | 16 + .../PrincipalKoszulPositivity.lean | 16 + .../PrincipalKoszulSupportOverBase.lean | 17 + .../RadicalMinimalPrimeInvolutivity.lean | 147 ++ .../Characteristic/ReducedSupportIdeal.lean | 150 ++ .../RightReesArtinianAdapter.lean | 225 +++ .../SourceActionCommutatorExpansion.lean | 487 +++++++ .../SpecializedNoncharacteristicEquality.lean | 302 ++++ .../SquareZeroAnnihilatorBracket.lean | 138 ++ .../SquareZeroArtinianTruncation.lean | 92 ++ .../SquareZeroHighPowerReduction.lean | 201 +++ .../Characteristic/SquareZeroLinearTrace.lean | 225 +++ .../SquareZeroLocalizedExactness.lean | 446 ++++++ .../SquareZeroLocalizedRing.lean | 154 ++ .../SquareZeroOreLocalization.lean | 181 +++ .../Characteristic/SquareZeroTraceData.lean | 153 ++ .../StableTorsionResidualSupport.lean | 16 + .../Characteristic/SymplecticCompletion.lean | 347 +++++ .../TransposedFilteredModuleSupport.lean | 342 +++++ .../Characteristic/TwoTermPageLength.lean | 15 + .../UniformBoundaryVanishing.lean | 13 + .../ZeroSectionContainment.lean | 122 ++ .../CoordinateDifferentialGeneration.lean | 15 + .../Stafford38/DifferentialOperators.lean | 20 + .../Stafford38/EulerRootSeparation.lean | 270 ++++ .../Stafford38/EvolutionaryCertificate.lean | 417 ++++++ .../Stafford38/EvolutionaryCorollary.lean | 98 ++ .../Stafford38/FixedSourceAssembly.lean | 118 ++ .../FixedSourceChallengeTransport.lean | 270 ++++ .../Stafford38/FixedSourceStatement.lean | 84 ++ .../Stafford38/FoundationClosure.lean | 68 + .../AffineComponentCoordinateSplit.lean | 111 ++ .../Geometry/AffineConormalClosure.lean | 98 ++ .../Geometry/AffineConormalSpan.lean | 219 +++ .../Stafford38/Geometry/ArcFrameConormal.lean | 141 ++ .../Geometry/AsymptoticChartArcAdapter.lean | 224 +++ .../Geometry/AsymptoticDivisorExistence.lean | 353 +++++ .../CanonicalAsymptoticLaurentProducer.lean | 254 ++++ .../CanonicalConstantCoordinateBranch.lean | 283 ++++ ...alFiniteGradientProjectiveCoordinates.lean | 98 ++ ...alNonconstantFiniteGradientProduction.lean | 106 ++ ...constantFiniteGradientProductionProof.lean | 129 ++ .../CanonicalResidueExtensionAssembly.lean | 266 ++++ ...anonicalVisibleDivisorFrameProduction.lean | 297 ++++ .../Geometry/ChartArcAnnihilation.lean | 202 +++ .../Geometry/CoisotropicTranslation.lean | 319 +++++ .../CompletedDVRCoefficientSection.lean | 330 +++++ .../CompletedDVRPowerSeriesEquiv.lean | 670 +++++++++ .../ComponentFunctionFieldBoundary.lean | 131 ++ .../Geometry/ComponentProjectiveClosure.lean | 306 ++++ ...mponentProjectiveClosureNormalization.lean | 307 ++++ .../Geometry/ComponentProjectiveOrder.lean | 308 ++++ .../Geometry/ConormalAxisContradiction.lean | 210 +++ .../ConormalPrincipalOpenDensity.lean | 160 +++ .../ConormalScalarExtensionVanishing.lean | 229 +++ .../Geometry/ConstantCoordinateConormal.lean | 130 ++ .../ContinuousPowerSeriesTangentFrame.lean | 299 ++++ .../Geometry/DivisorTangentLattice.lean | 348 +++++ .../Geometry/DivisorialBoundaryExtension.lean | 307 ++++ .../Geometry/DivisorialVisibleFrameCore.lean | 423 ++++++ .../DivisorialVisibleFrameStage2.lean | 223 +++ .../DivisorialVisibleFrameStage4.lean | 232 +++ .../DivisorialVisibleFrameStage5.lean | 191 +++ .../DivisorialVisibleFrameStageAssembly.lean | 226 +++ .../ExactDivisorialVisibleFrameExistence.lean | 425 ++++++ .../ExactVisibleDivisorFrameInterface.lean | 241 ++++ .../Geometry/FibreConicalVanishingIdeal.lean | 111 ++ .../FiniteGradientBoundaryProducer.lean | 190 +++ .../FiniteGradientFromTangentInclusion.lean | 146 ++ .../FiniteGradientResidueExtension.lean | 147 ++ .../FiniteSeparableDVRChartFoundation.lean | 128 ++ .../Geometry/FixedWitnessTangentSqueeze.lean | 66 + .../Geometry/FormalDivisorAxisLift.lean | 236 ++++ .../FormalDivisorLaurentConormal.lean | 200 +++ .../Geometry/FormalDivisorTangent.lean | 400 ++++++ .../Geometry/GeneralAsymptoticConormal.lean | 84 ++ .../GeneralAsymptoticLaurentAxis.lean | 59 + .../GeneralCoisotropicCanonicalAdapter.lean | 223 +++ .../Geometry/GeneralCoisotropicExclusion.lean | 78 ++ .../Geometry/GeneralCoisotropicSets.lean | 154 ++ .../Geometry/GeneralCoisotropicSetsTest.lean | 185 +++ .../GeneralComponentConormalContainment.lean | 167 +++ .../Geometry/GeneralConormalAxis.lean | 70 + .../Geometry/GeneralConormalContainment.lean | 172 +++ .../GeneralConstantCoordinateAxis.lean | 49 + .../Geometry/GeneralCoordinateAvoidance.lean | 54 + .../GeneralDivisorialVisibleFrame.lean | 213 +++ .../GeneralTangentLatticePresentation.lean | 17 + .../GeneralTangentLimitCriterion.lean | 575 ++++++++ .../GeneralTangentLimitCriterionTest.lean | 44 + .../Geometry/GenericPointKaehlerConormal.lean | 234 ++++ .../Geometry/GenericSmoothOpen.lean | 57 + .../Geometry/JacobianConormalComparison.lean | 177 +++ .../Geometry/KaehlerDVRVisibility.lean | 370 +++++ .../Geometry/KaehlerSpanSeparableAdjoin.lean | 163 +++ .../KaehlerVisibleDerivationFrame.lean | 149 ++ .../Geometry/LaurentConormalDirection.lean | 217 +++ .../LaurentConormalResidueExtension.lean | 329 +++++ .../LocalizedProjectiveChartTransition.lean | 404 ++++++ .../Geometry/NormalizationHeightOne.lean | 144 ++ .../Geometry/OneVariableAmbientConormal.lean | 265 ++++ .../Geometry/OneVariablePrimeConormal.lean | 155 ++ .../PointwiseConormalContainment.lean | 130 ++ .../Geometry/PowerSeriesArcTangency.lean | 421 ++++++ .../Geometry/PowerSeriesTangentLimit.lean | 143 ++ .../Geometry/ProjectiveBoundaryFrameRank.lean | 201 +++ .../ProjectiveConormalDehomogenization.lean | 167 +++ .../ProjectiveConormalDirections.lean | 117 ++ .../Geometry/ProjectiveDivisorOrderGap.lean | 200 +++ .../ProjectiveEquationFormalChart.lean | 198 +++ .../Geometry/ProjectiveTangentInclusion.lean | 164 +++ .../ProjectiveValuationNormalization.lean | 146 ++ .../Geometry/RelativeCoefficientDVRPlace.lean | 185 +++ .../Geometry/RelativeDivisorialTower.lean | 287 ++++ .../RelativeFractionFieldTransport.lean | 235 ++++ .../RelativeRetainedBoundaryPlace.lean | 193 +++ .../Geometry/ResidueMinorSelection.lean | 129 ++ .../RetainedComponentEquationPackage.lean | 191 +++ .../Stafford38/Geometry/RetainedDVRPlace.lean | 208 +++ .../RetainedGroundMapIdentification.lean | 212 +++ .../RetainedPlaceConormalTransport.lean | 603 ++++++++ .../RetainedProjectiveCompletion.lean | 202 +++ .../Geometry/RetractionSpecialization.lean | 246 ++++ .../Geometry/ScalarExtensionPoints.lean | 391 ++++++ .../SeparableResidueDerivationExtension.lean | 165 +++ .../Geometry/SmoothAffineConormal.lean | 83 ++ .../SmoothConormalFibreVanishing.lean | 47 + .../Geometry/SplitTangentMatrix.lean | 107 ++ .../Stafford38/LeftDenominatorTransport.lean | 19 + .../Stafford38/LeftHandedCorollary.lean | 40 + .../Stafford38/LocalizationCorollaries.lean | 41 + .../LocalizedDifferentialClearing.lean | 221 +++ .../LocalizedDifferentialCorollaries.lean | 146 ++ .../LocalizedPolynomialCommutant.lean | 15 + .../LocalizedPolynomialDerivations.lean | 17 + .../Stafford38/LocalizedWeylAction.lean | 163 +++ .../Stafford38/Ore/CoordinateStage.lean | 153 ++ .../Stafford38/Ore/IteratedPairStage.lean | 97 ++ .../Stafford38/Ore/LinearNormalForm.lean | 337 +++++ .../Stafford38/Stafford38/Ore/PairStage.lean | 132 ++ .../Stafford38/Ore/PairUniversal.lean | 250 ++++ .../Stafford38/Ore/ScalarAlgebra.lean | 70 + .../Stafford38/Stafford38/PaperInputs.lean | 95 ++ .../PolynomialDifferentialOperators.lean | 127 ++ .../PolynomialOperatorCommutators.lean | 136 ++ .../PolynomialOperatorTaylorProjection.lean | 187 +++ .../Quotient/EulerSurjectivity.lean | 143 ++ LeanPool/Stafford38/Stafford38/Statement.lean | 29 + .../Stafford38/UniversalAssembly.lean | 125 ++ .../Stafford38/Weyl/AssociatedGraded.lean | 214 +++ .../Stafford38/Weyl/CommutatorSymbol.lean | 184 +++ .../Weyl/CoordinateCommutatorSymbol.lean | 223 +++ .../Stafford38/Weyl/EulerRemainder.lean | 447 ++++++ .../Stafford38/Weyl/EulerResidue.lean | 116 ++ .../Stafford38/Weyl/EulerSubring.lean | 287 ++++ .../Stafford38/Weyl/FilteredCommutator.lean | 382 +++++ .../Weyl/FilteredScalarLifting.lean | 538 +++++++ .../Stafford38/Weyl/Filtration.lean | 599 ++++++++ .../Stafford38/Weyl/GradedAlgebra.lean | 226 +++ .../Stafford38/Weyl/IteratedEquivalence.lean | 659 +++++++++ .../Stafford38/Weyl/LeadingSymbol.lean | 661 +++++++++ .../Stafford38/Weyl/MonicNormalization.lean | 209 +++ .../Stafford38/Stafford38/Weyl/OrderRees.lean | 193 +++ .../Stafford38/Weyl/OuterOreMonic.lean | 356 +++++ LeanPool/Stafford38/Stafford38/Weyl/PBW.lean | 703 ++++++++++ .../Stafford38/Weyl/PBWFirstContraction.lean | 442 ++++++ .../Stafford38/Weyl/PBWMonicBridge.lean | 197 +++ .../Weyl/PresentedScalarExtension.lean | 611 ++++++++ .../Stafford38/Weyl/QuotientTransport.lean | 278 ++++ .../Stafford38/Weyl/SymbolCompatibility.lean | 455 ++++++ .../Stafford38/Weyl/Symplectic.lean | 167 +++ .../Stafford38/Weyl/Transposition.lean | 258 ++++ .../Weyl/TranspositionFiltration.lean | 772 ++++++++++ .../Stafford38/Stafford38/Weyl/Universal.lean | 66 + .../proofs/stafford38_reduction.lean | 112 ++ .../Stafford38/proofs/weyl_pure_power.lean | 520 +++++++ .../Stafford38/proofs/weyl_symplectic.lean | 425 ++++++ LeanPool/projects.yml | 35 + 349 files changed, 66999 insertions(+) create mode 100644 LeanPool/Stafford38.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Commutator.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/CommutatorRiccati.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Central.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Escape.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/Basic.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/CoordinateGeneration.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialCommutant.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialDerivations.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/FieldTheory/FunctionField.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/LinearAlgebra/FiniteTaylorReconstruction.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizationModuleComparison.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizedKoszulPositivity.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/CommutingPolynomialAction.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/DenominatorTorsion.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupport.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupportOverBase.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeAssembly.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeSpan.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredSchreyer.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredStrictness.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryExhaustion.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryNaturality.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageActions.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageEquivalences.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPages.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermSuccessorNaturality.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalActions.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalPages.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/FreeSummandInduction.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/HyperplaneRestriction.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedKernelCokernelEquivalences.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedMinimalSupportAvoidance.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalPrimeFiniteLengthLocalization.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportExistence.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportKernelCokernelLengths.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/MonicAnnihilatorFinite.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulFiniteTorsion.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulMinimalSupportPositivity.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulPositivity.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulSupportOverBase.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/RankExact.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/RankTorsion.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/RightCoordinates.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/Splice.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/SplitLatticePresentation.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/StableTorsionResidualSupport.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/StablyFree.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/TorsionProjectiveImage.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/TriangularDenominator.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoSimplicity.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoTermPageLength.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/UniformBoundaryVanishing.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Module/Unimodular.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/ActiveCoordinate.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/Associativity.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedPBW.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedTower.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/LeftPBW.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/Localization.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/LocalizationExtension.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/PrincipalRightIdeal.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightDivision.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightHilbertBasis.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightIntersection.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightLocalization.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightPBW.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightQuotient.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Ore/Tower.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/Polynomial/DistinguishedVariable.lean create mode 100644 LeanPool/Stafford38/AlgebraicAnalysis/RingTheory/TwoGeneratorIdentity.lean create mode 100644 LeanPool/Stafford38/FixedSourceSolution.lean create mode 100644 LeanPool/Stafford38/Solution.lean create mode 100644 LeanPool/Stafford38/Stafford38.lean create mode 100644 LeanPool/Stafford38/Stafford38/CanonicalSupportVanishingReduction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisExistence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisTraceAdapter.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ArtinianCoefficientField.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ArtinianEquation33TraceProducer.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ArtinianTriangularTrace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedFinite.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedModule.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/BGab001CoefficientFieldTrace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizationModuleComparison.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizedKoszulPositivity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/BaseRelativePoisson.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/BaseZeroSection.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisAvoidanceConsumer.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisMonicInitialTop.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalBaseVariety.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalCertificate.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredGradedBridge.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredTwoTerm.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGabberInvolutivityInterface.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGradedTangentialEquivalences.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalKoszulContradiction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalLaurentSymbolControl.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalMonicSaturation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNoncharacteristicCancellation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalAxisSupport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalSymbolFiniteness.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalOldTangentialFiniteness.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalPageEulerInequality.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalResidueExtensionSymbolControlAdapter.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalSupportAvoidanceFromCokernel.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialBoundaryMaps.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialPageOperators.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialRingEquivalence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSuccessors.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSymbolFiniteness.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialTotalAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedActionCompatibility.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedBridge.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitCoordinatePreimage.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitPreimageFromInitialTop.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/CommutingPolynomialAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ConcreteEquation33SourceMatrices.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ConcreteInducedZAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ConcreteLocalizedTwoBlockSpecialFibre.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ConcreteSquareZeroTraceData.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/EmptySupportVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupportOverBase.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotient.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientGraded.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientRees.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesExact.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSpecialFibre.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSupport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientTwoJet.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryExhaustion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryNaturality.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageActions.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageEquivalences.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPages.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermSuccessorNaturality.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalActions.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalPages.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/FilteredVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/GabberGlobalAssembly.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportDescent.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportScalarExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/HomogeneousChart.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/HyperplaneRestriction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/InitialIdeal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/InitialIdealHomogeneous.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LinearAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedHighPowerTwoBlockVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedKernelCokernelEquivalences.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedMinimalSupportAvoidance.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedOrderReesTwoJetSpecializationKernel.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedSpecializationActionCompatibility.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockModuleExactness.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockPrincipalKernelDescent.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockQuotient.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimeFiniteLengthLocalization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimePoisson.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportExistence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportKernelCokernelLengths.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/MonicAnnihilatorFinite.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/NoncharacteristicMinimalPrime.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/NormalSymbolPolynomial.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJet.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetBracket.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetSpecializationKernel.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/Polynomial.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/PostScalarExtensionPoisson.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulFiniteTorsion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulMinimalSupportPositivity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulPositivity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulSupportOverBase.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/RadicalMinimalPrimeInvolutivity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ReducedSupportIdeal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/RightReesArtinianAdapter.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SourceActionCommutatorExpansion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SpecializedNoncharacteristicEquality.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroAnnihilatorBracket.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroArtinianTruncation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroHighPowerReduction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLinearTrace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedExactness.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedRing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroOreLocalization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroTraceData.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/StableTorsionResidualSupport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/SymplecticCompletion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/TransposedFilteredModuleSupport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/TwoTermPageLength.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/UniformBoundaryVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Characteristic/ZeroSectionContainment.lean create mode 100644 LeanPool/Stafford38/Stafford38/CoordinateDifferentialGeneration.lean create mode 100644 LeanPool/Stafford38/Stafford38/DifferentialOperators.lean create mode 100644 LeanPool/Stafford38/Stafford38/EulerRootSeparation.lean create mode 100644 LeanPool/Stafford38/Stafford38/EvolutionaryCertificate.lean create mode 100644 LeanPool/Stafford38/Stafford38/EvolutionaryCorollary.lean create mode 100644 LeanPool/Stafford38/Stafford38/FixedSourceAssembly.lean create mode 100644 LeanPool/Stafford38/Stafford38/FixedSourceChallengeTransport.lean create mode 100644 LeanPool/Stafford38/Stafford38/FixedSourceStatement.lean create mode 100644 LeanPool/Stafford38/Stafford38/FoundationClosure.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/AffineComponentCoordinateSplit.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/AffineConormalClosure.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/AffineConormalSpan.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ArcFrameConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/AsymptoticChartArcAdapter.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/AsymptoticDivisorExistence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalAsymptoticLaurentProducer.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalConstantCoordinateBranch.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalFiniteGradientProjectiveCoordinates.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProduction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProductionProof.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalResidueExtensionAssembly.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CanonicalVisibleDivisorFrameProduction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ChartArcAnnihilation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CoisotropicTranslation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRCoefficientSection.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRPowerSeriesEquiv.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ComponentFunctionFieldBoundary.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosure.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosureNormalization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveOrder.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ConormalAxisContradiction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ConormalPrincipalOpenDensity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ConormalScalarExtensionVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ConstantCoordinateConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ContinuousPowerSeriesTangentFrame.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorTangentLattice.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialBoundaryExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameCore.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage2.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage4.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage5.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStageAssembly.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ExactDivisorialVisibleFrameExistence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ExactVisibleDivisorFrameInterface.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FibreConicalVanishingIdeal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientBoundaryProducer.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientFromTangentInclusion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientResidueExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FiniteSeparableDVRChartFoundation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FixedWitnessTangentSqueeze.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorAxisLift.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorLaurentConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorTangent.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticLaurentAxis.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicCanonicalAdapter.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicExclusion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSets.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSetsTest.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralComponentConormalContainment.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalAxis.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalContainment.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralConstantCoordinateAxis.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralCoordinateAvoidance.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralDivisorialVisibleFrame.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLatticePresentation.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterionTest.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GenericPointKaehlerConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/GenericSmoothOpen.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/JacobianConormalComparison.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/KaehlerDVRVisibility.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/KaehlerSpanSeparableAdjoin.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/KaehlerVisibleDerivationFrame.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalDirection.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalResidueExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/LocalizedProjectiveChartTransition.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/NormalizationHeightOne.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/OneVariableAmbientConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/OneVariablePrimeConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/PointwiseConormalContainment.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesArcTangency.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesTangentLimit.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveBoundaryFrameRank.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDehomogenization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDirections.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveDivisorOrderGap.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveEquationFormalChart.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveTangentInclusion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ProjectiveValuationNormalization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RelativeCoefficientDVRPlace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RelativeDivisorialTower.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RelativeFractionFieldTransport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RelativeRetainedBoundaryPlace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ResidueMinorSelection.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetainedComponentEquationPackage.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetainedDVRPlace.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetainedGroundMapIdentification.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetainedPlaceConormalTransport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetainedProjectiveCompletion.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/RetractionSpecialization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/ScalarExtensionPoints.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/SeparableResidueDerivationExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/SmoothAffineConormal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/SmoothConormalFibreVanishing.lean create mode 100644 LeanPool/Stafford38/Stafford38/Geometry/SplitTangentMatrix.lean create mode 100644 LeanPool/Stafford38/Stafford38/LeftDenominatorTransport.lean create mode 100644 LeanPool/Stafford38/Stafford38/LeftHandedCorollary.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizationCorollaries.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizedDifferentialClearing.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizedDifferentialCorollaries.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizedPolynomialCommutant.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizedPolynomialDerivations.lean create mode 100644 LeanPool/Stafford38/Stafford38/LocalizedWeylAction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/CoordinateStage.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/IteratedPairStage.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/LinearNormalForm.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/PairStage.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/PairUniversal.lean create mode 100644 LeanPool/Stafford38/Stafford38/Ore/ScalarAlgebra.lean create mode 100644 LeanPool/Stafford38/Stafford38/PaperInputs.lean create mode 100644 LeanPool/Stafford38/Stafford38/PolynomialDifferentialOperators.lean create mode 100644 LeanPool/Stafford38/Stafford38/PolynomialOperatorCommutators.lean create mode 100644 LeanPool/Stafford38/Stafford38/PolynomialOperatorTaylorProjection.lean create mode 100644 LeanPool/Stafford38/Stafford38/Quotient/EulerSurjectivity.lean create mode 100644 LeanPool/Stafford38/Stafford38/Statement.lean create mode 100644 LeanPool/Stafford38/Stafford38/UniversalAssembly.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/AssociatedGraded.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/CommutatorSymbol.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/CoordinateCommutatorSymbol.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/EulerRemainder.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/EulerResidue.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/EulerSubring.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/FilteredCommutator.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/FilteredScalarLifting.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/Filtration.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/GradedAlgebra.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/IteratedEquivalence.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/LeadingSymbol.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/MonicNormalization.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/OrderRees.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/OuterOreMonic.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/PBW.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/PBWFirstContraction.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/PBWMonicBridge.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/PresentedScalarExtension.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/QuotientTransport.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/SymbolCompatibility.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/Symplectic.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/Transposition.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/TranspositionFiltration.lean create mode 100644 LeanPool/Stafford38/Stafford38/Weyl/Universal.lean create mode 100644 LeanPool/Stafford38/proofs/stafford38_reduction.lean create mode 100644 LeanPool/Stafford38/proofs/weyl_pure_power.lean create mode 100644 LeanPool/Stafford38/proofs/weyl_symplectic.lean diff --git a/LeanPool.lean b/LeanPool.lean index 50fa6e5b30..2d0a0bc1e0 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -6634,6 +6634,353 @@ import LeanPool.SpherePacking.MellinAnalysis import LeanPool.SpherePacking.PackingBound import LeanPool.SpherePacking.RadialConstruction import LeanPool.SpherePacking.SaddleAnalysis +import LeanPool.Stafford38 +import LeanPool.Stafford38.AlgebraicAnalysis +import LeanPool.Stafford38.AlgebraicAnalysis.Commutator +import LeanPool.Stafford38.AlgebraicAnalysis.CommutatorRiccati +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Central +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Escape +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations +import LeanPool.Stafford38.AlgebraicAnalysis.FieldTheory.FunctionField +import LeanPool.Stafford38.AlgebraicAnalysis.LinearAlgebra.FiniteTaylorReconstruction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizationModuleComparison +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.CommutingPolynomialAction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.DenominatorTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeAssembly +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeSpan +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredSchreyer +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredStrictness +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FreeSummandInduction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.HyperplaneRestriction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportExistence +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MonicAnnihilatorFinite +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankExact +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RightCoordinates +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Splice +import LeanPool.Stafford38.AlgebraicAnalysis.Module.SplitLatticePresentation +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StableTorsionResidualSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StablyFree +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TorsionProjectiveImage +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TriangularDenominator +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoSimplicity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoTermPageLength +import LeanPool.Stafford38.AlgebraicAnalysis.Module.UniformBoundaryVanishing +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Unimodular +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.ActiveCoordinate +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedTower +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LeftPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Localization +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LocalizationExtension +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.PrincipalRightIdeal +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightDivision +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightHilbertBasis +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightIntersection +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightLocalization +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightQuotient +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Tower +import LeanPool.Stafford38.AlgebraicAnalysis.Polynomial.DistinguishedVariable +import LeanPool.Stafford38.AlgebraicAnalysis.RingTheory.TwoGeneratorIdentity +import LeanPool.Stafford38.FixedSourceSolution +import LeanPool.Stafford38.Solution +import LeanPool.Stafford38.Stafford38 +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisExistence +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianCoefficientField +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianEquation33TraceProducer +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianTriangularTrace +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Characteristic.BGab001CoefficientFieldTrace +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizationModuleComparison +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.BaseRelativePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.BaseZeroSection +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisAvoidanceConsumer +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisMonicInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalBaseVariety +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalCertificate +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredTwoTerm +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGabberInvolutivityInterface +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGradedTangentialEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalKoszulContradiction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalLaurentSymbolControl +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalMonicSaturation +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNoncharacteristicCancellation +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalAxisSupport +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalOldTangentialFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalPageEulerInequality +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalSupportAvoidanceFromCokernel +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialBoundaryMaps +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialPageOperators +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialRingEquivalence +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSuccessors +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialTotalAction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitCoordinatePreimage +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitPreimageFromInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.CommutingPolynomialAction +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteEquation33SourceMatrices +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteInducedZAction +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteSquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.EmptySupportVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupport +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotient +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientGraded +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientRees +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesAction +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesExact +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSupport +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientTwoJet +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPages +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalPages +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.GabberGlobalAssembly +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportDescent +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportScalarExtension +import LeanPool.Stafford38.Stafford38.Characteristic.HomogeneousChart +import LeanPool.Stafford38.Stafford38.Characteristic.HyperplaneRestriction +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous +import LeanPool.Stafford38.Stafford38.Characteristic.LinearAction +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedOrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedSpecializationActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockModuleExactness +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockQuotient +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportExistence +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.Stafford38.Characteristic.MonicAnnihilatorFinite +import LeanPool.Stafford38.Stafford38.Characteristic.NoncharacteristicMinimalPrime +import LeanPool.Stafford38.Stafford38.Characteristic.NormalSymbolPolynomial +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJet +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetBracket +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial +import LeanPool.Stafford38.Stafford38.Characteristic.PostScalarExtensionPoisson +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity +import LeanPool.Stafford38.Stafford38.Characteristic.ReducedSupportIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.RightReesArtinianAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.SourceActionCommutatorExpansion +import LeanPool.Stafford38.Stafford38.Characteristic.SpecializedNoncharacteristicEquality +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroAnnihilatorBracket +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroArtinianTruncation +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroHighPowerReduction +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLinearTrace +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedExactness +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedRing +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroOreLocalization +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.StableTorsionResidualSupport +import LeanPool.Stafford38.Stafford38.Characteristic.SymplecticCompletion +import LeanPool.Stafford38.Stafford38.Characteristic.TransposedFilteredModuleSupport +import LeanPool.Stafford38.Stafford38.Characteristic.TwoTermPageLength +import LeanPool.Stafford38.Stafford38.Characteristic.UniformBoundaryVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.ZeroSectionContainment +import LeanPool.Stafford38.Stafford38.CoordinateDifferentialGeneration +import LeanPool.Stafford38.Stafford38.DifferentialOperators +import LeanPool.Stafford38.Stafford38.EulerRootSeparation +import LeanPool.Stafford38.Stafford38.EvolutionaryCertificate +import LeanPool.Stafford38.Stafford38.EvolutionaryCorollary +import LeanPool.Stafford38.Stafford38.FixedSourceAssembly +import LeanPool.Stafford38.Stafford38.FixedSourceChallengeTransport +import LeanPool.Stafford38.Stafford38.FixedSourceStatement +import LeanPool.Stafford38.Stafford38.FoundationClosure +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan +import LeanPool.Stafford38.Stafford38.Geometry.ArcFrameConormal +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticChartArcAdapter +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticDivisorExistence +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalConstantCoordinateBranch +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalResidueExtensionAssembly +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +import LeanPool.Stafford38.Stafford38.Geometry.ChartArcAnnihilation +import LeanPool.Stafford38.Stafford38.Geometry.CoisotropicTranslation +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRCoefficientSection +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRPowerSeriesEquiv +import LeanPool.Stafford38.Stafford38.Geometry.ComponentFunctionFieldBoundary +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosure +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosureNormalization +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveOrder +import LeanPool.Stafford38.Stafford38.Geometry.ConormalAxisContradiction +import LeanPool.Stafford38.Stafford38.Geometry.ConormalPrincipalOpenDensity +import LeanPool.Stafford38.Stafford38.Geometry.ConormalScalarExtensionVanishing +import LeanPool.Stafford38.Stafford38.Geometry.ConstantCoordinateConormal +import LeanPool.Stafford38.Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +import LeanPool.Stafford38.Stafford38.Geometry.DivisorTangentLattice +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialBoundaryExtension +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameCore +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage2 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage4 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage5 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStageAssembly +import LeanPool.Stafford38.Stafford38.Geometry.ExactDivisorialVisibleFrameExistence +import LeanPool.Stafford38.Stafford38.Geometry.ExactVisibleDivisorFrameInterface +import LeanPool.Stafford38.Stafford38.Geometry.FibreConicalVanishingIdeal +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientBoundaryProducer +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientFromTangentInclusion +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.FiniteSeparableDVRChartFoundation +import LeanPool.Stafford38.Stafford38.Geometry.FixedWitnessTangentSqueeze +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorAxisLift +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorLaurentConormal +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorTangent +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticConormal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticLaurentAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicExclusion +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSets +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSetsTest +import LeanPool.Stafford38.Stafford38.Geometry.GeneralComponentConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConstantCoordinateAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoordinateAvoidance +import LeanPool.Stafford38.Stafford38.Geometry.GeneralDivisorialVisibleFrame +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLatticePresentation +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterion +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterionTest +import LeanPool.Stafford38.Stafford38.Geometry.GenericPointKaehlerConormal +import LeanPool.Stafford38.Stafford38.Geometry.GenericSmoothOpen +import LeanPool.Stafford38.Stafford38.Geometry.JacobianConormalComparison +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerDVRVisibility +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerSpanSeparableAdjoin +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerVisibleDerivationFrame +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.LocalizedProjectiveChartTransition +import LeanPool.Stafford38.Stafford38.Geometry.NormalizationHeightOne +import LeanPool.Stafford38.Stafford38.Geometry.OneVariableAmbientConormal +import LeanPool.Stafford38.Stafford38.Geometry.OneVariablePrimeConormal +import LeanPool.Stafford38.Stafford38.Geometry.PointwiseConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesArcTangency +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesTangentLimit +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveBoundaryFrameRank +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDehomogenization +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDirections +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveEquationFormalChart +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveTangentInclusion +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveValuationNormalization +import LeanPool.Stafford38.Stafford38.Geometry.RelativeCoefficientDVRPlace +import LeanPool.Stafford38.Stafford38.Geometry.RelativeDivisorialTower +import LeanPool.Stafford38.Stafford38.Geometry.RelativeFractionFieldTransport +import LeanPool.Stafford38.Stafford38.Geometry.RelativeRetainedBoundaryPlace +import LeanPool.Stafford38.Stafford38.Geometry.ResidueMinorSelection +import LeanPool.Stafford38.Stafford38.Geometry.RetainedComponentEquationPackage +import LeanPool.Stafford38.Stafford38.Geometry.RetainedDVRPlace +import LeanPool.Stafford38.Stafford38.Geometry.RetainedGroundMapIdentification +import LeanPool.Stafford38.Stafford38.Geometry.RetainedPlaceConormalTransport +import LeanPool.Stafford38.Stafford38.Geometry.RetainedProjectiveCompletion +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints +import LeanPool.Stafford38.Stafford38.Geometry.SeparableResidueDerivationExtension +import LeanPool.Stafford38.Stafford38.Geometry.SmoothAffineConormal +import LeanPool.Stafford38.Stafford38.Geometry.SmoothConormalFibreVanishing +import LeanPool.Stafford38.Stafford38.Geometry.SplitTangentMatrix +import LeanPool.Stafford38.Stafford38.LeftDenominatorTransport +import LeanPool.Stafford38.Stafford38.LeftHandedCorollary +import LeanPool.Stafford38.Stafford38.LocalizationCorollaries +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialClearing +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialCorollaries +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialCommutant +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialDerivations +import LeanPool.Stafford38.Stafford38.LocalizedWeylAction +import LeanPool.Stafford38.Stafford38.Ore.CoordinateStage +import LeanPool.Stafford38.Stafford38.Ore.IteratedPairStage +import LeanPool.Stafford38.Stafford38.Ore.LinearNormalForm +import LeanPool.Stafford38.Stafford38.Ore.PairStage +import LeanPool.Stafford38.Stafford38.Ore.PairUniversal +import LeanPool.Stafford38.Stafford38.Ore.ScalarAlgebra +import LeanPool.Stafford38.Stafford38.PaperInputs +import LeanPool.Stafford38.Stafford38.PolynomialDifferentialOperators +import LeanPool.Stafford38.Stafford38.PolynomialOperatorCommutators +import LeanPool.Stafford38.Stafford38.PolynomialOperatorTaylorProjection +import LeanPool.Stafford38.Stafford38.Quotient.EulerSurjectivity +import LeanPool.Stafford38.Stafford38.Statement +import LeanPool.Stafford38.Stafford38.UniversalAssembly +import LeanPool.Stafford38.Stafford38.Weyl.AssociatedGraded +import LeanPool.Stafford38.Stafford38.Weyl.CommutatorSymbol +import LeanPool.Stafford38.Stafford38.Weyl.CoordinateCommutatorSymbol +import LeanPool.Stafford38.Stafford38.Weyl.EulerRemainder +import LeanPool.Stafford38.Stafford38.Weyl.EulerResidue +import LeanPool.Stafford38.Stafford38.Weyl.EulerSubring +import LeanPool.Stafford38.Stafford38.Weyl.FilteredCommutator +import LeanPool.Stafford38.Stafford38.Weyl.FilteredScalarLifting +import LeanPool.Stafford38.Stafford38.Weyl.Filtration +import LeanPool.Stafford38.Stafford38.Weyl.GradedAlgebra +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence +import LeanPool.Stafford38.Stafford38.Weyl.LeadingSymbol +import LeanPool.Stafford38.Stafford38.Weyl.MonicNormalization +import LeanPool.Stafford38.Stafford38.Weyl.OrderRees +import LeanPool.Stafford38.Stafford38.Weyl.OuterOreMonic +import LeanPool.Stafford38.Stafford38.Weyl.PBW +import LeanPool.Stafford38.Stafford38.Weyl.PBWFirstContraction +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge +import LeanPool.Stafford38.Stafford38.Weyl.PresentedScalarExtension +import LeanPool.Stafford38.Stafford38.Weyl.QuotientTransport +import LeanPool.Stafford38.Stafford38.Weyl.SymbolCompatibility +import LeanPool.Stafford38.Stafford38.Weyl.Symplectic +import LeanPool.Stafford38.Stafford38.Weyl.Transposition +import LeanPool.Stafford38.Stafford38.Weyl.TranspositionFiltration +import LeanPool.Stafford38.Stafford38.Weyl.Universal +import LeanPool.Stafford38.proofs.stafford38_reduction +import LeanPool.Stafford38.proofs.weyl_pure_power +import LeanPool.Stafford38.proofs.weyl_symplectic import LeanPool.SteinhausThreeGap import LeanPool.SteinhausThreeGap.Basic import LeanPool.SumDifferenceExponent diff --git a/LeanPool/Stafford38.lean b/LeanPool/Stafford38.lean new file mode 100644 index 0000000000..6b70e686e0 --- /dev/null +++ b/LeanPool/Stafford38.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis +import LeanPool.Stafford38.AlgebraicAnalysis.Commutator +import LeanPool.Stafford38.AlgebraicAnalysis.CommutatorRiccati +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Central +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Escape +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations +import LeanPool.Stafford38.AlgebraicAnalysis.FieldTheory.FunctionField +import LeanPool.Stafford38.AlgebraicAnalysis.LinearAlgebra.FiniteTaylorReconstruction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizationModuleComparison +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.CommutingPolynomialAction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.DenominatorTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeAssembly +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeSpan +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredSchreyer +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredStrictness +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FreeSummandInduction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.HyperplaneRestriction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportExistence +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MonicAnnihilatorFinite +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankExact +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RightCoordinates +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Splice +import LeanPool.Stafford38.AlgebraicAnalysis.Module.SplitLatticePresentation +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StableTorsionResidualSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StablyFree +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TorsionProjectiveImage +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TriangularDenominator +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoSimplicity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoTermPageLength +import LeanPool.Stafford38.AlgebraicAnalysis.Module.UniformBoundaryVanishing +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Unimodular +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.ActiveCoordinate +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedTower +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LeftPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Localization +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LocalizationExtension +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.PrincipalRightIdeal +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightDivision +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightHilbertBasis +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightIntersection +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightLocalization +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightQuotient +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Tower +import LeanPool.Stafford38.AlgebraicAnalysis.Polynomial.DistinguishedVariable +import LeanPool.Stafford38.AlgebraicAnalysis.RingTheory.TwoGeneratorIdentity +import LeanPool.Stafford38.FixedSourceSolution +import LeanPool.Stafford38.Solution +import LeanPool.Stafford38.Stafford38 +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisExistence +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianCoefficientField +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianEquation33TraceProducer +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianTriangularTrace +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Characteristic.BGab001CoefficientFieldTrace +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizationModuleComparison +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.BaseRelativePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.BaseZeroSection +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisAvoidanceConsumer +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisMonicInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalBaseVariety +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalCertificate +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredTwoTerm +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGabberInvolutivityInterface +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGradedTangentialEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalKoszulContradiction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalLaurentSymbolControl +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalMonicSaturation +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNoncharacteristicCancellation +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalAxisSupport +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalOldTangentialFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalPageEulerInequality +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalSupportAvoidanceFromCokernel +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialBoundaryMaps +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialPageOperators +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialRingEquivalence +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSuccessors +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialTotalAction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitCoordinatePreimage +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitPreimageFromInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.CommutingPolynomialAction +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteEquation33SourceMatrices +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteInducedZAction +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteSquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.EmptySupportVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupport +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotient +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientGraded +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientRees +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesAction +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesExact +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSupport +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientTwoJet +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPages +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalPages +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.GabberGlobalAssembly +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportDescent +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportScalarExtension +import LeanPool.Stafford38.Stafford38.Characteristic.HomogeneousChart +import LeanPool.Stafford38.Stafford38.Characteristic.HyperplaneRestriction +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous +import LeanPool.Stafford38.Stafford38.Characteristic.LinearAction +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedOrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedSpecializationActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockModuleExactness +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockQuotient +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportExistence +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.Stafford38.Characteristic.MonicAnnihilatorFinite +import LeanPool.Stafford38.Stafford38.Characteristic.NoncharacteristicMinimalPrime +import LeanPool.Stafford38.Stafford38.Characteristic.NormalSymbolPolynomial +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJet +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetBracket +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial +import LeanPool.Stafford38.Stafford38.Characteristic.PostScalarExtensionPoisson +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity +import LeanPool.Stafford38.Stafford38.Characteristic.ReducedSupportIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.RightReesArtinianAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.SourceActionCommutatorExpansion +import LeanPool.Stafford38.Stafford38.Characteristic.SpecializedNoncharacteristicEquality +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroAnnihilatorBracket +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroArtinianTruncation +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroHighPowerReduction +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLinearTrace +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedExactness +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedRing +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroOreLocalization +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.StableTorsionResidualSupport +import LeanPool.Stafford38.Stafford38.Characteristic.SymplecticCompletion +import LeanPool.Stafford38.Stafford38.Characteristic.TransposedFilteredModuleSupport +import LeanPool.Stafford38.Stafford38.Characteristic.TwoTermPageLength +import LeanPool.Stafford38.Stafford38.Characteristic.UniformBoundaryVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.ZeroSectionContainment +import LeanPool.Stafford38.Stafford38.CoordinateDifferentialGeneration +import LeanPool.Stafford38.Stafford38.DifferentialOperators +import LeanPool.Stafford38.Stafford38.EulerRootSeparation +import LeanPool.Stafford38.Stafford38.EvolutionaryCertificate +import LeanPool.Stafford38.Stafford38.EvolutionaryCorollary +import LeanPool.Stafford38.Stafford38.FixedSourceAssembly +import LeanPool.Stafford38.Stafford38.FixedSourceChallengeTransport +import LeanPool.Stafford38.Stafford38.FixedSourceStatement +import LeanPool.Stafford38.Stafford38.FoundationClosure +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan +import LeanPool.Stafford38.Stafford38.Geometry.ArcFrameConormal +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticChartArcAdapter +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticDivisorExistence +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalConstantCoordinateBranch +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalResidueExtensionAssembly +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +import LeanPool.Stafford38.Stafford38.Geometry.ChartArcAnnihilation +import LeanPool.Stafford38.Stafford38.Geometry.CoisotropicTranslation +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRCoefficientSection +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRPowerSeriesEquiv +import LeanPool.Stafford38.Stafford38.Geometry.ComponentFunctionFieldBoundary +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosure +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosureNormalization +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveOrder +import LeanPool.Stafford38.Stafford38.Geometry.ConormalAxisContradiction +import LeanPool.Stafford38.Stafford38.Geometry.ConormalPrincipalOpenDensity +import LeanPool.Stafford38.Stafford38.Geometry.ConormalScalarExtensionVanishing +import LeanPool.Stafford38.Stafford38.Geometry.ConstantCoordinateConormal +import LeanPool.Stafford38.Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +import LeanPool.Stafford38.Stafford38.Geometry.DivisorTangentLattice +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialBoundaryExtension +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameCore +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage2 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage4 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage5 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStageAssembly +import LeanPool.Stafford38.Stafford38.Geometry.ExactDivisorialVisibleFrameExistence +import LeanPool.Stafford38.Stafford38.Geometry.ExactVisibleDivisorFrameInterface +import LeanPool.Stafford38.Stafford38.Geometry.FibreConicalVanishingIdeal +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientBoundaryProducer +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientFromTangentInclusion +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.FiniteSeparableDVRChartFoundation +import LeanPool.Stafford38.Stafford38.Geometry.FixedWitnessTangentSqueeze +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorAxisLift +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorLaurentConormal +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorTangent +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticConormal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticLaurentAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicExclusion +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSets +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSetsTest +import LeanPool.Stafford38.Stafford38.Geometry.GeneralComponentConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConstantCoordinateAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoordinateAvoidance +import LeanPool.Stafford38.Stafford38.Geometry.GeneralDivisorialVisibleFrame +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLatticePresentation +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterion +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterionTest +import LeanPool.Stafford38.Stafford38.Geometry.GenericPointKaehlerConormal +import LeanPool.Stafford38.Stafford38.Geometry.GenericSmoothOpen +import LeanPool.Stafford38.Stafford38.Geometry.JacobianConormalComparison +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerDVRVisibility +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerSpanSeparableAdjoin +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerVisibleDerivationFrame +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.LocalizedProjectiveChartTransition +import LeanPool.Stafford38.Stafford38.Geometry.NormalizationHeightOne +import LeanPool.Stafford38.Stafford38.Geometry.OneVariableAmbientConormal +import LeanPool.Stafford38.Stafford38.Geometry.OneVariablePrimeConormal +import LeanPool.Stafford38.Stafford38.Geometry.PointwiseConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesArcTangency +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesTangentLimit +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveBoundaryFrameRank +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDehomogenization +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDirections +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveEquationFormalChart +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveTangentInclusion +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveValuationNormalization +import LeanPool.Stafford38.Stafford38.Geometry.RelativeCoefficientDVRPlace +import LeanPool.Stafford38.Stafford38.Geometry.RelativeDivisorialTower +import LeanPool.Stafford38.Stafford38.Geometry.RelativeFractionFieldTransport +import LeanPool.Stafford38.Stafford38.Geometry.RelativeRetainedBoundaryPlace +import LeanPool.Stafford38.Stafford38.Geometry.ResidueMinorSelection +import LeanPool.Stafford38.Stafford38.Geometry.RetainedComponentEquationPackage +import LeanPool.Stafford38.Stafford38.Geometry.RetainedDVRPlace +import LeanPool.Stafford38.Stafford38.Geometry.RetainedGroundMapIdentification +import LeanPool.Stafford38.Stafford38.Geometry.RetainedPlaceConormalTransport +import LeanPool.Stafford38.Stafford38.Geometry.RetainedProjectiveCompletion +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints +import LeanPool.Stafford38.Stafford38.Geometry.SeparableResidueDerivationExtension +import LeanPool.Stafford38.Stafford38.Geometry.SmoothAffineConormal +import LeanPool.Stafford38.Stafford38.Geometry.SmoothConormalFibreVanishing +import LeanPool.Stafford38.Stafford38.Geometry.SplitTangentMatrix +import LeanPool.Stafford38.Stafford38.LeftDenominatorTransport +import LeanPool.Stafford38.Stafford38.LeftHandedCorollary +import LeanPool.Stafford38.Stafford38.LocalizationCorollaries +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialClearing +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialCorollaries +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialCommutant +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialDerivations +import LeanPool.Stafford38.Stafford38.LocalizedWeylAction +import LeanPool.Stafford38.Stafford38.Ore.CoordinateStage +import LeanPool.Stafford38.Stafford38.Ore.IteratedPairStage +import LeanPool.Stafford38.Stafford38.Ore.LinearNormalForm +import LeanPool.Stafford38.Stafford38.Ore.PairStage +import LeanPool.Stafford38.Stafford38.Ore.PairUniversal +import LeanPool.Stafford38.Stafford38.Ore.ScalarAlgebra +import LeanPool.Stafford38.Stafford38.PaperInputs +import LeanPool.Stafford38.Stafford38.PolynomialDifferentialOperators +import LeanPool.Stafford38.Stafford38.PolynomialOperatorCommutators +import LeanPool.Stafford38.Stafford38.PolynomialOperatorTaylorProjection +import LeanPool.Stafford38.Stafford38.Quotient.EulerSurjectivity +import LeanPool.Stafford38.Stafford38.Statement +import LeanPool.Stafford38.Stafford38.UniversalAssembly +import LeanPool.Stafford38.Stafford38.Weyl.AssociatedGraded +import LeanPool.Stafford38.Stafford38.Weyl.CommutatorSymbol +import LeanPool.Stafford38.Stafford38.Weyl.CoordinateCommutatorSymbol +import LeanPool.Stafford38.Stafford38.Weyl.EulerRemainder +import LeanPool.Stafford38.Stafford38.Weyl.EulerResidue +import LeanPool.Stafford38.Stafford38.Weyl.EulerSubring +import LeanPool.Stafford38.Stafford38.Weyl.FilteredCommutator +import LeanPool.Stafford38.Stafford38.Weyl.FilteredScalarLifting +import LeanPool.Stafford38.Stafford38.Weyl.Filtration +import LeanPool.Stafford38.Stafford38.Weyl.GradedAlgebra +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence +import LeanPool.Stafford38.Stafford38.Weyl.LeadingSymbol +import LeanPool.Stafford38.Stafford38.Weyl.MonicNormalization +import LeanPool.Stafford38.Stafford38.Weyl.OrderRees +import LeanPool.Stafford38.Stafford38.Weyl.OuterOreMonic +import LeanPool.Stafford38.Stafford38.Weyl.PBW +import LeanPool.Stafford38.Stafford38.Weyl.PBWFirstContraction +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge +import LeanPool.Stafford38.Stafford38.Weyl.PresentedScalarExtension +import LeanPool.Stafford38.Stafford38.Weyl.QuotientTransport +import LeanPool.Stafford38.Stafford38.Weyl.SymbolCompatibility +import LeanPool.Stafford38.Stafford38.Weyl.Symplectic +import LeanPool.Stafford38.Stafford38.Weyl.Transposition +import LeanPool.Stafford38.Stafford38.Weyl.TranspositionFiltration +import LeanPool.Stafford38.Stafford38.Weyl.Universal +import LeanPool.Stafford38.proofs.stafford38_reduction +import LeanPool.Stafford38.proofs.weyl_pure_power +import LeanPool.Stafford38.proofs.weyl_symplectic + +/-! +# Stafford 3.8 + +Source: url:https://github.com/itpplasma/stafford38-formal +Authors: Christopher Albert +Status: verified +Main declarations: `Stafford38.universalStatement`, `Stafford38.universalFixedSourceStatement` +Tags: weyl-algebras, noncommutative-algebra, bernstein-degree +MSC: 16S32 +-/ + +/- +Retained upstream notice: + +Copyright 2026 Christopher Albert + +This project is distributed under the Apache License, Version 2.0. The full +license text is provided in LICENSE. + +The project depends on Lean, Mathlib, and the separately distributed +AlgebraicAnalysis library. Those projects retain their own copyright notices +and licenses. + +scripts/landrun-wrapper.sh is adapted from PalomarRegistry/PalomarTemplate +at commit 128a6c5ce5f48622e69927ccd639cbff401022e8, under Apache-2.0: +https://github.com/PalomarRegistry/PalomarTemplate/blob/128a6c5ce5f48622e69927ccd639cbff401022e8/scripts/landrun-wrapper.sh +The adaptation accepts an outer command delimiter already supplied by +Comparator while preserving the rejection of unrestricted sandbox flags. + +The Stafford 3.8 manuscript, bibliography, figures, and supplements are +separate works maintained under the private Overleaf authority and licensed +CC BY 4.0. They are not included in this repository. + +-/ diff --git a/LeanPool/Stafford38/AlgebraicAnalysis.lean b/LeanPool/Stafford38/AlgebraicAnalysis.lean new file mode 100644 index 0000000000..3a4dd26121 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Commutator +import LeanPool.Stafford38.AlgebraicAnalysis.RingTheory.TwoGeneratorIdentity +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic +import LeanPool.Stafford38.AlgebraicAnalysis.CommutatorRiccati +import LeanPool.Stafford38.AlgebraicAnalysis.FieldTheory.FunctionField +import LeanPool.Stafford38.AlgebraicAnalysis.Polynomial.DistinguishedVariable +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.ActiveCoordinate +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Central +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Escape +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightHilbertBasis +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightIntersection +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.PrincipalRightIdeal +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Localization +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LocalizationExtension +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LeftPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Tower +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedTower +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedPBW +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StablyFree +import LeanPool.Stafford38.AlgebraicAnalysis.Module.HyperplaneRestriction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredStrictness +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankExact +import LeanPool.Stafford38.AlgebraicAnalysis.Module.DenominatorTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TriangularDenominator +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Unimodular +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FreeSummandInduction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TorsionProjectiveImage +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredSchreyer +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Splice +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoSimplicity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeSpan +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeAssembly +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RightCoordinates +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.AlgebraicAnalysis.Module.CommutingPolynomialAction +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizationModuleComparison +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StableTorsionResidualSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportExistence +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoTermPageLength +import LeanPool.Stafford38.AlgebraicAnalysis.Module.UniformBoundaryVanishing +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MonicAnnihilatorFinite +import LeanPool.Stafford38.AlgebraicAnalysis.Module.SplitLatticePresentation +import LeanPool.Stafford38.AlgebraicAnalysis.LinearAlgebra.FiniteTaylorReconstruction +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightLocalization + +/-! +# AlgebraicAnalysis + +Root module for reusable formal mathematics in algebraic analysis. +-/ diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Commutator.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Commutator.lean new file mode 100644 index 0000000000..839c0c9f6a --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Commutator.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Ring commutators + +This module contains the multiplication identities used by both the Weyl +symplectic layer and the differential-Ore escape layer. The convention is +`[u,v] = u*v - v*u`; no Weyl relation, Ore presentation, or application +specific structure is assumed. +-/ + +namespace AlgebraicAnalysis + +section + +variable {A : Type*} [Ring A] + +/-- The ring commutator, with the written multiplication order retained. -/ +def ringCommutator (u v : A) : A := u * v - v * u + +@[simp] theorem ringCommutator_apply (u v : A) : + ringCommutator u v = u * v - v * u := rfl + +/-- Leibniz expansion in the first argument. -/ +theorem ringCommutator_mul (u v x : A) : + ringCommutator (u * v) x = + u * ringCommutator v x + ringCommutator u x * v := by + simp only [ringCommutator] + noncomm_ring + +/-- Iterated commutation with a Weyl-type relation. -/ +theorem ringCommutator_pow (z x : A) (h : ringCommutator z x = 1) : + ∀ n : ℕ, ringCommutator (z ^ n) x = n • z ^ (n - 1) + | 0 => by simp [ringCommutator] + | n + 1 => by + rw [pow_succ, ringCommutator_mul, h, ringCommutator_pow z x h n] + by_cases hn : n = 0 + · subst n + simp + · rw [smul_mul_assoc, Nat.succ_sub_one, mul_one, add_nsmul] + have hpow : z ^ (n - 1) * z = z ^ n := by + rw [← pow_succ, Nat.sub_add_cancel (Nat.pos_of_ne_zero hn)] + rw [hpow, one_nsmul] + exact add_comm _ _ + +end + +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/CommutatorRiccati.lean b/LeanPool/Stafford38/AlgebraicAnalysis/CommutatorRiccati.lean new file mode 100644 index 0000000000..7f5d6f1b3e --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/CommutatorRiccati.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib +import LeanPool.Stafford38.AlgebraicAnalysis.Commutator + +/-! +# Inverse-Euler/Riccati commutator identities + +This module contains the purely ring-theoretic identities behind the +inverse-Euler calculation. No Weyl presentation, filtration, module, or +application-specific hypothesis is assumed. +-/ + +namespace AlgebraicAnalysis.InverseEulerRiccati + +variable {A : Type*} [Ring A] + +/-- Historical local name for the shared ring commutator. -/ +def commutator (a b : A) : A := AlgebraicAnalysis.ringCommutator a b + +@[simp] theorem commutator_eq_shared (a b : A) : + commutator a b = AlgebraicAnalysis.ringCommutator a b := rfl + +/-- Iterated commutation by a fixed element. -/ +def adIterate (p : A) : ℕ → A → A + | 0, z => z + | n + 1, z => commutator p (adIterate p n z) + +/-- Inverting the relation `P*X-X*P=-1` produces the Riccati identity. -/ +theorem inverse_riccati + (P X T : A) + (hPX : P * X - X * P = -1) + (hXT : X * T = 1) + (hTX : T * X = 1) : + P * T - T * P = T * T := by + have hright : P - X * P * T = -T := by + have h := congrArg (fun z : A => z * T) hPX + simpa [sub_mul, mul_assoc, hXT] using h + have hleft : T * P - P * T = -(T * T) := by + have htxpt : T * (X * P * T) = P * T := by + calc + T * (X * P * T) = (T * X) * P * T := by noncomm_ring + _ = P * T := by rw [hTX]; simp + calc + T * P - P * T = T * P - T * (X * P * T) := by rw [htxpt] + _ = T * (P - X * P * T) := by rw [mul_sub] + _ = T * (-T) := by rw [hright] + _ = -(T * T) := by simp + calc + P * T - T * P = -(T * P - P * T) := by noncomm_ring + _ = -(-(T * T)) := by rw [hleft] + _ = T * T := by simp + +/-- The Euler element `H = P*X` has commutator `T`. -/ +theorem euler_commutator + (P X T : A) + (hPX : P * X - X * P = -1) + (hXT : X * T = 1) + (hTX : T * X = 1) : + (P * X) * T - T * (P * X) = T := by + have htxp : T * (X * P) = P := by + calc + T * (X * P) = (T * X) * P := by rw [mul_assoc] + _ = P := by rw [hTX]; simp + have hleft : T * (P * X) - P = -T := by + calc + T * (P * X) - P = T * (P * X) - T * (X * P) := by rw [htxp] + _ = T * (P * X - X * P) := by rw [mul_sub] + _ = T * (-1) := by rw [hPX] + _ = -T := by simp + have htp : T * (P * X) = P - T := by + calc + T * (P * X) = (T * (P * X) - P) + P := by noncomm_ring + _ = (-T) + P := by rw [hleft] + _ = P - T := by noncomm_ring + calc + (P * X) * T - T * (P * X) = P - T * (P * X) := by + simp [mul_assoc, hXT] + _ = T := by rw [htp]; noncomm_ring + +private theorem commutator_nat_mul (P Z : A) (m : ℕ) : + commutator P ((m : A) * Z) = (m : A) * commutator P Z := by + have hcentral : ∀ z : A, (m : A) * z = z * (m : A) := by + intro z + exact Nat.cast_comm m z + unfold commutator + calc + P * ((m : A) * Z) - ((m : A) * Z) * P = + ((m : A) * (P * Z)) - ((m : A) * (Z * P)) := by + calc + P * ((m : A) * Z) - ((m : A) * Z) * P = + ((P * (m : A)) * Z) - ((m : A) * Z) * P := by + exact congrArg (fun q : A => q - ((m : A) * Z) * P) + (mul_assoc P (m : A) Z).symm + _ = (((m : A) * P) * Z) - ((m : A) * Z) * P := by + rw [hcentral P] + _ = (((m : A) * P) * Z) - (m : A) * (Z * P) := by + exact congrArg (fun q : A => (((m : A) * P) * Z) - q) + (mul_assoc (m : A) Z P) + _ = (m : A) * (P * Z) - (m : A) * (Z * P) := by + rw [mul_assoc] + _ = (m : A) * (P * Z - Z * P) := by rw [mul_sub] + +private theorem commutator_pow + (P T : A) + (hPT : P * T - T * P = T * T) : + ∀ n : ℕ, commutator P (T ^ n) = (n : A) * T ^ (n + 1) := by + intro n + induction n with + | zero => simp [commutator] + | succ n ih => + calc + commutator P (T ^ (n + 1)) = + commutator P (T ^ n) * T + T ^ n * commutator P T := by + simp only [commutator, AlgebraicAnalysis.ringCommutator, pow_succ] + noncomm_ring + _ = (n : A) * T ^ (n + 1) * T + + T ^ n * (P * T - T * P) := by + rw [ih] + rfl + _ = (n : A) * T ^ (n + 1) * T + T ^ n * (T * T) := by + rw [hPT] + _ = ((n + 1 : ℕ) : A) * T ^ ((n + 1) + 1) := by + rw [Nat.cast_succ] + simp only [pow_succ] + noncomm_ring + +/-- The iterated commutator is the factorial Riccati tower. -/ +theorem iterated_commutator + (P X T : A) + (hPX : P * X - X * P = -1) + (hXT : X * T = 1) + (hTX : T * X = 1) : + ∀ n : ℕ, adIterate P n T = (n.factorial : A) * T ^ (n + 1) := by + have hPT : P * T - T * P = T * T := + inverse_riccati P X T hPX hXT hTX + intro n + induction n with + | zero => simp [adIterate] + | succ n ih => + calc + adIterate P (n + 1) T = commutator P (adIterate P n T) := by rfl + _ = commutator P ((n.factorial : A) * T ^ (n + 1)) := by rw [ih] + _ = (n.factorial : A) * commutator P (T ^ (n + 1)) := by + exact commutator_nat_mul P (T ^ (n + 1)) n.factorial + _ = (n.factorial : A) * (((n + 1 : ℕ) : A) * + T ^ ((n + 1) + 1)) := by + rw [commutator_pow P T hPT (n + 1)] + _ = ((n + 1).factorial : A) * T ^ ((n + 1) + 1) := by + simp [Nat.factorial_succ, Nat.cast_succ, Nat.cast_mul, + mul_assoc, Nat.cast_comm] + + +end AlgebraicAnalysis.InverseEulerRiccati diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Central.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Central.lean new file mode 100644 index 0000000000..dbaa953c2f --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Central.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Centrality and inner derivations + +This file contains the noncommutative derivation facts used by the +algebraic-analysis stages. Mathlib's `Derivation` is specialized to +commutative coefficient rings, so the Leibniz and innerness predicates are +recorded directly for additive maps on arbitrary rings. + +The fraction-presentation lemma is deliberately stated with all hypotheses +visible. It does not assert that a particular localization has those +properties. +-/ + +namespace AlgebraicAnalysis.NoncommutativeDerivation + +variable {E : Type*} [Ring E] [Nontrivial E] + +/-- Leibniz rule for an additive derivation of a possibly noncommutative ring. -/ +def IsDerivation (d : E →+ E) : Prop := + ∀ a b : E, d (a * b) = a * d b + d a * b + +/-- An additive derivation is inner when it is a commutator with one element. -/ +def IsInnerDerivation (d : E →+ E) : Prop := + ∃ e : E, ∀ y : E, d y = e * y - y * e + +@[nolint unusedArguments] +theorem not_isInnerDerivation_of_central + (d : E →+ E) (hd : IsDerivation d) (x : E) + (hxcentral : ∀ y : E, x * y = y * x) (hdx : d x = 1) : + ¬ IsInnerDerivation d := by + intro hinner + obtain ⟨e, he⟩ := hinner + have h := he x + rw [hdx, hxcentral e] at h + exact (one_ne_zero : (1 : E) ≠ 0) (by simpa using h) + +/-- Commutation with a set propagates through the subring it generates. -/ +@[nolint unusedArguments] +theorem commute_of_mem_subring_closure + (x : E) (G : Set E) (hG : ∀ g ∈ G, Commute x g) : + ∀ y : E, y ∈ Subring.closure G → Commute x y := by + intro y hy + induction hy using Subring.closure_induction with + | mem z hz => exact hG z hz + | zero => exact Commute.zero_right x + | one => exact Commute.one_right x + | add a b ha hb hca hcb => exact hca.add_right hcb + | neg a ha hca => exact hca.neg_right + | mul a b ha hb hca hcb => exact hca.mul_right hcb + +/-- +A central element of a source ring remains central in a target ring when +every target element has a right-fraction presentation and every denominator +maps to a unit. No commutativity of either ring is assumed. +-/ +@[nolint unusedArguments] +theorem commute_map_of_right_fraction_representation + {R : Type*} [Ring R] + (ι : R →+* E) (x : R) + (hcentral : ∀ y : R, Commute x y) + (hunit : ∀ s : R, IsUnit (ι s)) + (hrep : ∀ z : E, ∃ c s : R, z * ι s = ι c) : + ∀ z : E, Commute (ι x) z := by + intro z + obtain ⟨c, s, hs⟩ := hrep z + apply (hunit s).mul_right_cancel + calc + (ι x * z) * ι s = ι x * (z * ι s) := by rw [mul_assoc] + _ = ι x * ι c := by rw [hs] + _ = ι (x * c) := by rw [ι.map_mul] + _ = ι (c * x) := by rw [(hcentral c).eq] + _ = ι c * ι x := by rw [ι.map_mul] + _ = (z * ι s) * ι x := by rw [hs] + _ = (z * ι x) * ι s := by + rw [mul_assoc, mul_assoc, ((hcentral s).map ι).eq] + +/-- +A derivation that sends a central coordinate to `1` cannot be inner. This is +the form consumed by differential-Ore stage arguments. +-/ +theorem not_inner_of_central_coordinate + (d : E →+ E) (hd : IsDerivation d) (x : E) + (hxcentral : ∀ y : E, Commute x y) (hdx : d x = 1) : + ¬ IsInnerDerivation d := + not_isInnerDerivation_of_central d hd x (fun y => (hxcentral y).eq) hdx + + +end AlgebraicAnalysis.NoncommutativeDerivation diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Escape.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Escape.lean new file mode 100644 index 0000000000..163a8721d3 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Derivation/Escape.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# The central-coordinate escape kernel + +This file contains the part of the central-coordinate escape argument which +is independent of the later Stafford module bookkeeping. The coefficient +ring is a division ring `E`; `normal` is the coefficient-left PBW normal form +for a differential Ore extension `S`; and `commutator` is the additive map +`w ↦ w x - x w`. The only Ore-specific input needed by the kernel is the +transport identity + +`normal (derivative p) = commutator (normal p)`. + +The resulting theorem says that iterating `ad(x)` by the PBW degree produces +the nonzero scalar `d! · lc(p)`, hence a unit. The hypotheses are explicit so +that a later concrete Ore-stage file must prove the transport identity rather +than hiding it behind an axiom. + +No module-span, simplicity, denominator, or geometric statement is included: +those are separate packet obligations. +-/ + +namespace AlgebraicAnalysis.Escape + +open Polynomial + +noncomputable section + + +variable {E S : Type*} [DivisionRing E] [Ring S] + +/-- The additive commutator map with a fixed right-hand coordinate `x`. + +The orientation is the one used in the escape argument: +`adₓ(w) = w x - x w`. +-/ +def commutator (x : S) : S →+ S where + toFun w := w * x - x * w + map_zero' := by simp + map_add' w v := by simp [add_mul, mul_add, sub_eq_add_neg, add_assoc, + add_left_comm, add_comm] + +@[simp] theorem commutator_apply (x w : S) : + commutator x w = w * x - x * w := rfl + +/-- Correct central-coordinate PBW data for a differential Ore stage. -/ +structure CentralEscapeData where + /-- Coefficient-left normal form for the Ore stage. -/ + normal : Polynomial E ≃+ S + /-- Ring embedding of coefficients into the Ore stage. -/ + embed : E →+* S + /-- The central coefficient coordinate used by the commutator. -/ + coordinate : E + normal_C : ∀ a : E, normal (C a) = embed a + embed_isUnit : ∀ {a : E}, a ≠ 0 → IsUnit (embed a) + ad_normal_derivative : + ∀ p : Polynomial E, + commutator (embed coordinate) (normal p) = normal (derivative p) + +namespace CentralEscapeData + +variable (D : CentralEscapeData (E := E) (S := S)) + +lemma iterate_commutator_normal (p : Polynomial E) (k : ℕ) : + ((commutator (D.embed D.coordinate))^[k]) (D.normal p) = + D.normal ((derivative^[k]) p) := by + induction k with + | zero => simp + | succ k ih => + calc + ((commutator (D.embed D.coordinate))^[k.succ]) (D.normal p) = + commutator (D.embed D.coordinate) + (((commutator (D.embed D.coordinate))^[k]) (D.normal p)) := + Function.iterate_succ_apply' _ _ _ + _ = commutator (D.embed D.coordinate) (D.normal ((derivative^[k]) p)) := + congrArg (commutator (D.embed D.coordinate)) ih + _ = D.normal (derivative ((derivative^[k]) p)) := + D.ad_normal_derivative _ + _ = D.normal ((derivative^[k.succ]) p) := by + rw [Function.iterate_succ_apply'] + +lemma iterate_derivative_natDegree (p : Polynomial E) : + derivative^[p.natDegree] p = + C ((Nat.factorial p.natDegree) • p.leadingCoeff) := by + apply Polynomial.ext + intro m + by_cases hm : m = 0 + · subst m + rw [coeff_iterate_derivative] + simp only [Nat.zero_add, Nat.descFactorial_self, coeff_C_zero, + smul_eq_mul, coeff_natDegree] + · have hlt : p.natDegree < m + p.natDegree := by + omega + have hcoeff : p.coeff (m + p.natDegree) = 0 := + coeff_eq_zero_of_natDegree_lt hlt + rw [coeff_iterate_derivative, hcoeff, smul_zero, coeff_C] + simp [hm] + +lemma factorial_leadingCoeff_ne_zero [CharZero E] {p : Polynomial E} (hp : p ≠ 0) : + (Nat.factorial p.natDegree) • p.leadingCoeff ≠ 0 := by + rw [nsmul_eq_mul'] + exact mul_ne_zero (leadingCoeff_ne_zero.mpr hp) + (Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _)) + +/-- Faithfulness of a differential-operator action from central-coordinate +PBW data. The action only needs to agree with left multiplication on the +coefficient embedding; iterated commutators then recover a nonzero leading +coefficient of every nonzero normal polynomial. -/ +lemma regular_action_injective [CharZero E] + (D : CentralEscapeData (E := E) (S := S)) + (action : S →+* AddMonoid.End E) + (haction : ∀ (a c : E), action (D.embed a) c = a * c) : + Function.Injective action := by + apply (injective_iff_map_eq_zero action).mpr + intro z hz + obtain ⟨p, rfl⟩ := D.normal.surjective z + have hpzero : p = 0 := by + by_contra hp + have hzero : action (D.normal p) = 0 := hz + have hiter : ∀ m : ℕ, + action (((commutator (D.embed D.coordinate))^[m]) (D.normal p)) = 0 := by + intro m + induction m with + | zero => simpa using hzero + | succ m ih => + rw [Function.iterate_succ_apply'] + simp only [commutator_apply, map_sub, map_mul, ih, + zero_mul, mul_zero, sub_zero] + have hlast := hiter p.natDegree + rw [iterate_commutator_normal D p p.natDegree, + iterate_derivative_natDegree] at hlast + have hcoeff : (Nat.factorial p.natDegree) • p.leadingCoeff = 0 := by + have hvalue := congrArg (fun f : AddMonoid.End E => f 1) hlast + rw [D.normal_C, haction] at hvalue + change (Nat.factorial p.natDegree • p.leadingCoeff) * 1 = 0 at hvalue + simpa using hvalue + exact (factorial_leadingCoeff_ne_zero hp) hcoeff + rw [hpzero] + exact D.normal.map_zero + +/-- One commutator lowers a nonconstant PBW polynomial's degree. -/ +@[nolint unusedArguments] +lemma ad_degree_reduction [CharZero E] {p : Polynomial E} + (hpositive : p.natDegree ≠ 0) : + (derivative p).natDegree < p.natDegree ∧ + commutator (D.embed D.coordinate) (D.normal p) = + D.normal (derivative p) := by + exact ⟨natDegree_derivative_lt hpositive, D.ad_normal_derivative p⟩ + +/-- Iterated `ad(x)` produces a nonzero coefficient, hence a unit. -/ +lemma ad_unit_production [CharZero E] {p : Polynomial E} (hp : p ≠ 0) : + IsUnit + (((commutator (D.embed D.coordinate))^[p.natDegree]) (D.normal p)) := by + rw [iterate_commutator_normal D, iterate_derivative_natDegree] + rw [D.normal_C] + exact D.embed_isUnit (factorial_leadingCoeff_ne_zero hp) + +end CentralEscapeData + +/-! Axiom report for the proof-critical kernel. -/ + +end +end AlgebraicAnalysis.Escape diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/Basic.lean b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/Basic.lean new file mode 100644 index 0000000000..e327ade836 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/Basic.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Algebra.Subalgebra.Basic + +/-! +# Finite-order differential operators + +Neutral extraction of the intrinsic finite-order differential-operator algebra +from Stafford38 commit `1585e4c7`, originally +`Stafford38/DifferentialOperators.lean`. No Weyl presentation or +application-specific hypothesis is used. +-/ + +namespace AlgebraicAnalysis.DifferentialOperators + +variable {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] + +/-- `k`-linear endomorphisms of the `k`-algebra `R`. -/ +abbrev End := Module.End k R + +/-- Multiplication by an element of `R`, as a `k`-linear endomorphism. -/ +def multiplication (a : R) : End (k := k) (R := R) := + LinearMap.mulLeft k a + +@[simp] theorem multiplication_apply (a x : R) : + multiplication (k := k) a x = a * x := rfl + +/-- The commutator of an endomorphism with multiplication by `a`. -/ +def commutator (P : End (k := k) (R := R)) (a : R) : End (k := k) (R := R) := + P * multiplication (k := k) a - multiplication (k := k) a * P + +@[simp] theorem commutator_apply (P : End (k := k) (R := R)) (a x : R) : + commutator P a x = P (a * x) - a * P x := rfl + +/-- Differential operators of order at most `n`. -/ +def order : ℕ → Submodule k (End (k := k) (R := R)) + | 0 => + { carrier := {P | ∀ a, commutator P a = 0} + zero_mem' := by simp [commutator] + add_mem' := by + intro P Q hP hQ a + have heq : commutator (P + Q) a = commutator P a + commutator Q a := by + ext x + simp [commutator_apply, mul_add, sub_eq_add_neg, add_assoc, add_comm, + add_left_comm] + calc + commutator (P + Q) a = commutator P a + commutator Q a := heq + _ = 0 := by rw [hP a, hQ a, add_zero] + smul_mem' := by + intro c P hP a + have heq : commutator (c • P) a = c • commutator P a := by + ext x + simp [commutator_apply, smul_sub] + rw [heq, hP a, smul_zero] } + | n + 1 => + { carrier := {P | ∀ a, commutator P a ∈ order n} + zero_mem' := by simp [commutator] + add_mem' := by + intro P Q hP hQ a + have heq : commutator (P + Q) a = commutator P a + commutator Q a := by + ext x + simp [commutator_apply, mul_add, sub_eq_add_neg, add_assoc, add_comm, + add_left_comm] + rw [heq] + exact (order n).add_mem (hP a) (hQ a) + smul_mem' := by + intro c P hP a + have heq : commutator (c • P) a = c • commutator P a := by + ext x + simp [commutator_apply, smul_sub] + rw [heq] + exact (order n).smul_mem c (hP a) } + +@[simp] theorem mem_order_zero_iff (P : End (k := k) (R := R)) : + P ∈ order (k := k) (R := R) 0 ↔ ∀ a, commutator P a = 0 := Iff.rfl + +@[simp] theorem mem_order_succ_iff (P : End (k := k) (R := R)) (n : ℕ) : + P ∈ order (k := k) (R := R) (n + 1) ↔ + ∀ a, commutator P a ∈ order n := by + change (∀ a, commutator P a ∈ order n) ↔ _ + rfl + +theorem mem_order_zero_iff_eq_multiplication (P : End (k := k) (R := R)) : + P ∈ order (k := k) (R := R) 0 ↔ + P = multiplication (k := k) (P 1) := by + constructor + · intro h + ext a + have ha := LinearMap.congr_fun (h a) 1 + simpa [mul_comm] using sub_eq_zero.mp (by simpa [commutator_apply] using ha) + · intro hP + rw [mem_order_zero_iff] + intro a + rw [hP] + ext x + simp [commutator_apply, mul_assoc, mul_comm] + +theorem order_mono_step (n : ℕ) : + order (k := k) (R := R) n ≤ order (n + 1) := by + induction n with + | zero => + intro P hP + rw [mem_order_succ_iff] + intro a + rw [hP a] + exact (order 0).zero_mem + | succ n ih => + intro P hP + rw [mem_order_succ_iff] at hP ⊢ + intro a + exact ih (hP a) + +theorem order_mono {m n : ℕ} (h : m ≤ n) : + order (k := k) (R := R) m ≤ order n := by + induction n, h using Nat.le_induction with + | base => exact le_rfl + | succ n _ ih => exact ih.trans (order_mono_step n) + +theorem commutator_mul (P Q : End (k := k) (R := R)) (a : R) : + commutator (P * Q) a = P * commutator Q a + commutator P a * Q := by + ext x + simp [commutator_apply, Module.End.mul_apply] + +private theorem orderZero_mul {P Q : End (k := k) (R := R)} {n : ℕ} + (hP : P ∈ order (k := k) (R := R) 0) (hQ : Q ∈ order n) : + P * Q ∈ order n := by + induction n generalizing Q with + | zero => + rw [mem_order_zero_iff_eq_multiplication] at hP hQ + rw [mem_order_zero_iff] + intro a + rw [hP, hQ] + ext x + simp [commutator_apply, mul_assoc, mul_comm, mul_left_comm] + | succ n ih => + rw [mem_order_succ_iff] at hQ ⊢ + intro a + rw [commutator_mul, hP a, zero_mul, add_zero] + exact ih (hQ a) + +/-- Orders add under composition. -/ +theorem mul_mem_order {P Q : End (k := k) (R := R)} {m n : ℕ} + (hP : P ∈ order (k := k) (R := R) m) (hQ : Q ∈ order n) : + P * Q ∈ order (m + n) := by + induction m generalizing P n Q with + | zero => simpa using orderZero_mul hP hQ + | succ m ihm => + induction n generalizing P Q with + | zero => + rw [Nat.add_zero, mem_order_succ_iff] at hP ⊢ + intro a + rw [commutator_mul, hQ a, mul_zero, zero_add] + simpa using ihm (hP a) hQ + | succ n ihn => + have hQ' : Q ∈ order (n + 1) := hQ + rw [mem_order_succ_iff] at hP hQ + rw [Nat.add_succ, mem_order_succ_iff] + intro a + rw [commutator_mul] + exact (order ((m + 1) + n)).add_mem + (ihn hP (hQ a)) + (by simpa only [Nat.succ_add, Nat.add_succ] using ihm (hP a) hQ') + +/-- The algebra of all finite-order `k`-linear differential operators on `R`. -/ +def algebra : Subalgebra k (End (k := k) (R := R)) where + carrier := {P | ∃ n, P ∈ order n} + zero_mem' := ⟨0, (order 0).zero_mem⟩ + add_mem' := by + rintro P Q ⟨m, hP⟩ ⟨n, hQ⟩ + refine ⟨max m n, (order (max m n)).add_mem ?_ ?_⟩ + · exact order_mono (Nat.le_max_left _ _) hP + · exact order_mono (Nat.le_max_right _ _) hQ + mul_mem' := by + rintro P Q ⟨m, hP⟩ ⟨n, hQ⟩ + exact ⟨m + n, mul_mem_order hP hQ⟩ + one_mem' := by + refine ⟨0, (mem_order_zero_iff_eq_multiplication _).2 ?_⟩ + ext x + simp [multiplication_apply] + algebraMap_mem' := by + intro c + refine ⟨0, (mem_order_zero_iff_eq_multiplication _).2 ?_⟩ + ext x + simp [multiplication_apply] + +@[simp] theorem mem_algebra_iff (P : End (k := k) (R := R)) : + P ∈ algebra (k := k) (R := R) ↔ ∃ n, P ∈ order n := Iff.rfl + +/-! The two basic kinds of operators are finite-order without any geometric +assumption. Keeping these witnesses public lets a concrete carrier expose +its coefficient and derivation generators through this neutral API. -/ + +/-- Multiplication by a coefficient is an intrinsic differential operator of +order zero. -/ +theorem multiplication_mem_algebra (a : R) : + multiplication (k := k) a ∈ algebra (k := k) (R := R) := by + refine ⟨0, (mem_order_zero_iff_eq_multiplication _).2 ?_⟩ + ext x + simp [multiplication_apply] + +end AlgebraicAnalysis.DifferentialOperators diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/CoordinateGeneration.lean b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/CoordinateGeneration.lean new file mode 100644 index 0000000000..9246ef5b71 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/CoordinateGeneration.lean @@ -0,0 +1,399 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic +import LeanPool.Stafford38.AlgebraicAnalysis.LinearAlgebra.FiniteTaylorReconstruction +import Mathlib.RingTheory.Derivation.Basic + +/-! +# Generation from coordinates and coordinate derivations + +This is the presentation-free coordinate-elimination argument. A finite +family of elements and dual derivations generates every intrinsic finite-order +differential operator, provided that commuting with all the coordinates +already characterizes multiplication operators. +-/ + +namespace AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration + + +open AlgebraicAnalysis.DifferentialOperators +open AlgebraicAnalysis.FiniteTaylorReconstruction + +noncomputable section + +variable {k R : Type*} [Field k] [CharZero k] [CommRing R] [Algebra k R] + +private def delta (x : R) : Module.End k R →ₗ[k] Module.End k R := + { toFun := fun P => commutator P x + map_add' := by + intro P Q + ext y + simp [commutator_apply, mul_add] + abel + map_smul' := by + intro c P + ext y + simp [commutator_apply, smul_sub] } + +private def rightComposition (D : Module.End k R) : + Module.End k R →ₗ[k] Module.End k R := LinearMap.mulRight k D + +omit [CharZero k] in +private lemma rightComposition_pow_apply (D : Module.End k R) + (a : ℕ) (P : Module.End k R) : + (rightComposition D ^ a) P = P * D ^ a := by + induction a with + | zero => simp [rightComposition] + | succ a ih => + rw [pow_succ', Module.End.mul_apply, ih] + simp [rightComposition, pow_succ, mul_assoc] + +omit [CharZero k] in +private lemma delta_mul (x : R) (P Q : Module.End k R) : + delta x (P * Q) = delta x P * Q + P * delta x Q := by + simpa [delta, add_comm] using commutator_mul P Q x + +omit [CharZero k] in +private lemma delta_right_derivation (x : R) (D : Derivation k R R) : + delta x D.toLinearMap = multiplication (D x) := by + ext y + simp [delta, commutator_apply, multiplication_apply, mul_comm] + +omit [CharZero k] in +private lemma deltas_commute (x y : R) (P : Module.End k R) : + delta x (delta y P) = delta y (delta x P) := by + ext z + simp [delta, commutator_apply] + ring_nf + +omit [CharZero k] in +private lemma delta_iterate_preserves_kernel (x y : R) (a : ℕ) + (P : Module.End k R) (hP : delta y P = 0) : + delta y ((delta x ^ a) P) = 0 := by + induction a with + | zero => simpa using hP + | succ a ih => + rw [pow_succ', Module.End.mul_apply] + rw [deltas_commute, ih] + exact (delta x).map_zero + +omit [CharZero k] in +private lemma right_derivation_preserves_kernel (y : R) (D : Derivation k R R) + (hxy : D y = 0) (a : ℕ) (P : Module.End k R) + (hP : delta y P = 0) : + delta y ((rightComposition D.toLinearMap ^ a) P) = 0 := by + induction a with + | zero => simpa using hP + | succ a ih => + rw [pow_succ', Module.End.mul_apply] + change delta y (rightComposition D.toLinearMap + ((rightComposition D.toLinearMap ^ a) P)) = 0 + rw [show rightComposition D.toLinearMap + ((rightComposition D.toLinearMap ^ a) P) = + (rightComposition D.toLinearMap ^ a) P * D.toLinearMap by rfl, + delta_mul, delta_right_derivation, hxy] + rw [ih, zero_mul, zero_add] + congr + ext z + simp [multiplication_apply] + +omit [CharZero k] in +private lemma delta_mem_order {m : ℕ} (x : R) (P : Module.End k R) + (hP : P ∈ order (k := k) (R := R) (m + 1)) : + delta x P ∈ order (k := k) (R := R) m := hP x + +omit [CharZero k] in +private lemma delta_pow_order_zero (m : ℕ) (x : R) + (P : Module.End k R) (hP : P ∈ order (k := k) (R := R) m) : + (delta x ^ (m + 1)) P = 0 := by + induction m generalizing P with + | zero => + rw [pow_one] + exact hP x + | succ m ih => + rw [pow_succ, Module.End.mul_apply] + exact ih (delta x P) (delta_mem_order x P hP) + +omit [CharZero k] in +private lemma delta_pow_after_zero (x : R) (m a : ℕ) (P : Module.End k R) + (h : (delta x ^ m) P = 0) : + (delta x ^ m) ((delta x ^ a) P) = 0 := by + rw [← Module.End.mul_apply, ← pow_add] + rw [Nat.add_comm] + rw [pow_add, Module.End.mul_apply, h, map_zero] + +omit [CharZero k] in +private lemma delta_mem_algebra (x : R) (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : + delta x P ∈ algebra (k := k) (R := R) := by + rcases hP with ⟨m, hm⟩ + cases m with + | zero => + refine ⟨0, ?_⟩ + change commutator P x ∈ order 0 + rw [hm x] + exact (order 0).zero_mem + | succ m => exact ⟨m, delta_mem_order x P hm⟩ + +omit [CharZero k] in +private lemma delta_pow_mem_algebra (x : R) (a : ℕ) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : + (delta x ^ a) P ∈ algebra (k := k) (R := R) := by + induction a with + | zero => simpa using hP + | succ a ih => + rw [pow_succ', Module.End.mul_apply] + exact delta_mem_algebra x _ ih + +private def projection (x : R) (D : Derivation k R R) (m : ℕ) + (P : Module.End k R) : Module.End k R := + ∑ a ∈ Finset.range (m + 1), + ((-1 : k) ^ a / (a.factorial : k)) • ((delta x ^ a) P * D.toLinearMap ^ a) + +omit [CharZero k] in +private lemma projectorMapG_apply (x : R) (D : Derivation k R R) (m : ℕ) + (P : Module.End k R) : + projectorMapG m (rightComposition D.toLinearMap) (delta x) P = + projection x D m P := by + unfold projectorMapG projection + rw [LinearMap.sum_apply] + apply Finset.sum_congr rfl + intro a ha + simp only [LinearMap.smul_apply, Module.End.mul_apply] + rw [rightComposition_pow_apply] + +private lemma delta_derivation_pow (x : R) (D : Derivation k R R) + (hDx : D x = 1) : ∀ a : ℕ, + delta x (D.toLinearMap ^ a) = (a : k) • D.toLinearMap ^ (a - 1) + | 0 => by + ext y + simp [delta, commutator_apply, multiplication_apply] + | a + 1 => by + rw [pow_succ, delta_mul, delta_right_derivation, hDx, + delta_derivation_pow x D hDx a] + cases a with + | zero => + ext y + simp [multiplication_apply] + | succ a => + ext y + simp [pow_succ, add_mul, add_smul, multiplication_apply] + +private lemma projection_kernel (x : R) (D : Derivation k R R) (hDx : D x = 1) + (m : ℕ) (P : Module.End k R) + (hnil : (delta x ^ (m + 1)) P = 0) : + delta x (projection x D m P) = 0 := by + simp only [projection, map_sum] + have hterm (a : ℕ) : + delta x (((-1 : k) ^ a / (a.factorial : k)) • + ((delta x ^ a) P * D.toLinearMap ^ a)) = + ((-1 : k) ^ a / (a.factorial : k)) • + (((delta x ^ (a + 1)) P * D.toLinearMap ^ a) + + ((a : k) • ((delta x ^ a) P * D.toLinearMap ^ (a - 1)))) := by + rw [map_smul, delta_mul, delta_derivation_pow x D hDx] + rw [show delta x ((delta x ^ a) P) = (delta x ^ (a + 1)) P by + rw [pow_succ', Module.End.mul_apply]] + simp only [smul_add] + rw [mul_smul_comm, smul_smul] + simp_rw [hterm] + simp only [smul_add, Finset.sum_add_distrib] + rw [Finset.sum_range_succ, hnil] + simp only [zero_mul, smul_zero, add_zero] + rw [Finset.sum_range_succ'] + simp only [Nat.cast_zero, zero_smul, zero_add] + have hcancel (a : ℕ) : + ((-1 : k) ^ a / (a.factorial : k)) • + ((delta x ^ (a + 1)) P * D.toLinearMap ^ a) + + ((-1 : k) ^ (a + 1) / ((a + 1).factorial : k)) • + ((a + 1 : k) • + ((delta x ^ (a + 1)) P * D.toLinearMap ^ a)) = 0 := by + have ha : ((a + 1 : ℕ) : k) ≠ 0 := by exact_mod_cast Nat.succ_ne_zero a + have hfac : ((a.factorial : ℕ) : k) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero a + have hc : ((-1 : k) ^ a / (a.factorial : k)) + + ((-1 : k) ^ (a + 1) / ((a + 1).factorial : k)) * (a + 1 : k) = 0 := by + rw [Nat.factorial_succ, Nat.cast_mul, Nat.cast_succ] + field_simp [hfac, ha] + ring + rw [smul_smul, ← add_smul, hc, zero_smul] + simp only [smul_zero, add_zero] + rw [← Finset.sum_add_distrib] + apply Finset.sum_eq_zero + intro a ha + simpa [Nat.succ_sub_one] using hcancel a + +omit [CharZero k] in +private lemma projection_preserves_kernel (x y : R) (D : Derivation k R R) + (hDy : D y = 0) (m : ℕ) (P : Module.End k R) + (hP : delta y P = 0) : delta y (projection x D m P) = 0 := by + simp only [projection, map_sum, map_smul] + apply Finset.sum_eq_zero + intro a ha + rw [delta_mul] + have hpow : delta y (D.toLinearMap ^ a) = 0 := by + have h := right_derivation_preserves_kernel y D hDy a (1 : Module.End k R) + (by ext z; simp [delta, commutator_apply]) + simpa [rightComposition_pow_apply] using h + rw [delta_iterate_preserves_kernel x y a P hP, hpow] + simp + +/-! A derivation is a finite-order operator. This is exported separately from +the coordinate-generation theorem so concrete carriers can expose their +derivation generators without importing an application-specific predicate. -/ +omit [CharZero k] in +theorem derivation_mem_algebra (D : Derivation k R R) : + D.toLinearMap ∈ algebra (k := k) (R := R) := by + refine ⟨1, ?_⟩ + rw [mem_order_succ_iff] + intro r + change delta r D.toLinearMap ∈ order 0 + rw [delta_right_derivation] + apply (mem_order_zero_iff_eq_multiplication _).2 + ext z + simp [multiplication_apply] + +omit [CharZero k] in +private lemma projection_mem_algebra (x : R) (D : Derivation k R R) (m : ℕ) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : projection x D m P ∈ algebra := by + unfold projection + apply (algebra (k := k) (R := R)).sum_mem + intro a ha + apply (algebra (k := k) (R := R)).smul_mem + exact (algebra (k := k) (R := R)).mul_mem + (delta_pow_mem_algebra x a P hP) + ((algebra (k := k) (R := R)).pow_mem (derivation_mem_algebra D) a) + +/-- Finite-order variant: the coordinate-rigidity hypothesis is required only +for operators in `algebra`. Every intrinsic finite-order differential +operator belongs to any linear subspace containing all multiplications and +stable under right composition by a finite dual coordinate frame. No +multiplicative closure of the subspace, or commutation hypothesis among the +derivations, is required. -/ +theorem mem_submodule_of_coordinates' + {n : ℕ} (x : Fin n → R) (D : Fin n → Derivation k R R) + (hdual : ∀ i j, D i (x j) = if i = j then 1 else 0) + (hcoordinate : ∀ P : Module.End k R, P ∈ algebra (k := k) (R := R) → + (∀ i, commutator P (x i) = 0) → + P = multiplication (P 1)) + (H : Submodule k (Module.End k R)) + (hmul : ∀ r : R, multiplication r ∈ H) + (hright : ∀ i Q, Q ∈ H → Q * (D i).toLinearMap ∈ H) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : P ∈ H := by + have hright_pow : ∀ i a (Q : Module.End k R), Q ∈ H → + Q * (D i).toLinearMap ^ a ∈ H := by + intro i a + induction a with + | zero => + intro Q hQ + simpa using hQ + | succ a ih => + intro Q hQ + rw [pow_succ, ← mul_assoc] + exact hright i _ (ih Q hQ) + have heliminate : ∀ l : List (Fin n), l.Nodup → + (∀ Q : Module.End k R, + Q ∈ algebra (k := k) (R := R) → + (∀ i ∈ l, delta (x i) Q = 0) → Q ∈ H) → + ∀ Q : Module.End k R, + Q ∈ algebra (k := k) (R := R) → Q ∈ H := by + intro l hnod + induction l with + | nil => + intro hend Q hQ + exact hend Q hQ (by simp) + | cons i l ih => + have hinot : i ∉ l := (List.nodup_cons.mp hnod).1 + have hlnod : l.Nodup := (List.nodup_cons.mp hnod).2 + intro hend + apply ih hlnod + intro Q hQ hkern + rcases hQ with ⟨m, hm⟩ + have hnil : (delta (x i) ^ (m + 1)) Q = 0 := + delta_pow_order_zero m (x i) Q hm + rw [reconstruction_all m (rightComposition (D i).toLinearMap) + (delta (x i)) Q hnil] + apply Submodule.sum_mem + intro a ha + apply Submodule.smul_mem + rw [Module.End.mul_apply, Module.End.mul_apply, + projectorMapG_apply, rightComposition_pow_apply] + apply hright_pow + apply hend _ (projection_mem_algebra (x i) (D i) m _ + (delta_pow_mem_algebra (x i) a Q ⟨m, hm⟩)) + intro j hj + simp only [List.mem_cons] at hj + rcases hj with hji | hj + · subst j + exact projection_kernel (x i) (D i) (by simpa using hdual i i) + m _ (delta_pow_after_zero (x i) (m + 1) a Q hnil) + · have hij : i ≠ j := fun e => hinot (e ▸ hj) + apply projection_preserves_kernel (x i) (x j) (D i) + (by rw [hdual, if_neg hij]) + exact delta_iterate_preserves_kernel (x i) (x j) a Q (hkern j hj) + apply heliminate (List.ofFn fun i : Fin n => i) + (List.nodup_ofFn.mpr fun _ _ h => h) ?_ P hP + intro Q hQ hkern + rw [hcoordinate Q hQ (fun i => by + simpa [delta] using hkern i (List.mem_ofFn.mpr ⟨i, rfl⟩))] + exact hmul (Q 1) + +/-- Every intrinsic finite-order differential operator belongs to any linear +subspace containing all multiplications and stable under right composition by +a finite dual coordinate frame. No multiplicative closure of the subspace, +or commutation hypothesis among the derivations, is required. -/ +theorem mem_submodule_of_coordinates + {n : ℕ} (x : Fin n → R) (D : Fin n → Derivation k R R) + (hdual : ∀ i j, D i (x j) = if i = j then 1 else 0) + (hcoordinate : ∀ P : Module.End k R, + (∀ i, commutator P (x i) = 0) → + P = multiplication (P 1)) + (H : Submodule k (Module.End k R)) + (hmul : ∀ r : R, multiplication r ∈ H) + (hright : ∀ i Q, Q ∈ H → Q * (D i).toLinearMap ∈ H) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : P ∈ H := + mem_submodule_of_coordinates' x D hdual (fun P _ h => hcoordinate P h) H + hmul hright P hP + +/-- Finite-order variant: the coordinate-rigidity hypothesis is required only +for operators in `algebra`. Subalgebras containing the coordinate +derivations satisfy the weaker right-stability hypothesis automatically. -/ +theorem mem_subalgebra_of_coordinates' + {n : ℕ} (x : Fin n → R) (D : Fin n → Derivation k R R) + (hdual : ∀ i j, D i (x j) = if i = j then 1 else 0) + (hcoordinate : ∀ P : Module.End k R, P ∈ algebra (k := k) (R := R) → + (∀ i, commutator P (x i) = 0) → + P = multiplication (P 1)) + (H : Subalgebra k (Module.End k R)) + (hmul : ∀ r : R, multiplication r ∈ H) + (hder : ∀ i, (D i).toLinearMap ∈ H) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : P ∈ H := by + apply mem_submodule_of_coordinates' x D hdual hcoordinate H.toSubmodule + hmul (fun i Q hQ => H.mul_mem hQ (hder i)) P hP + +/-- Subalgebras containing the coordinate derivations satisfy the weaker +right-stability hypothesis automatically. -/ +theorem mem_subalgebra_of_coordinates + {n : ℕ} (x : Fin n → R) (D : Fin n → Derivation k R R) + (hdual : ∀ i j, D i (x j) = if i = j then 1 else 0) + (hcoordinate : ∀ P : Module.End k R, + (∀ i, commutator P (x i) = 0) → + P = multiplication (P 1)) + (H : Subalgebra k (Module.End k R)) + (hmul : ∀ r : R, multiplication r ∈ H) + (hder : ∀ i, (D i).toLinearMap ∈ H) + (P : Module.End k R) + (hP : P ∈ algebra (k := k) (R := R)) : P ∈ H := + mem_subalgebra_of_coordinates' x D hdual (fun P _ h => hcoordinate P h) H + hmul hder P hP + +end +end AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialCommutant.lean b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialCommutant.lean new file mode 100644 index 0000000000..99b1649088 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialCommutant.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic +import Mathlib.RingTheory.Kaehler.Polynomial + +/-! +# The polynomial commutant after localization + +An endomorphism of a localization which commutes with the coordinate +multiplications is multiplication by its value at `1`. The argument only +uses the localization presentation; it does not use a finite-order +hypothesis. +-/ + +namespace AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant + +open AlgebraicAnalysis.DifferentialOperators + +noncomputable section + +variable {k : Type*} [CommRing k] +variable {n : ℕ} +variable (B : Type*) [CommRing B] +variable [Algebra k B] +variable (S : Submonoid (MvPolynomial (Fin n) k)) +variable [Algebra (MvPolynomial (Fin n) k) B] +variable [IsScalarTower k (MvPolynomial (Fin n) k) B] +variable [IsLocalization S B] + +theorem eq_multiplication_of_commute_coordinate + (S : Submonoid (MvPolynomial (Fin n) k)) + [IsLocalization S B] + (P : Module.End k B) + (hcoord : ∀ i : Fin n, ∀ b : B, + P (algebraMap (MvPolynomial (Fin n) k) B (MvPolynomial.X i) * b) = + algebraMap (MvPolynomial (Fin n) k) B (MvPolynomial.X i) * P b) : + P = multiplication (k := k) (P 1) := by + have hpoly : ∀ a : MvPolynomial (Fin n) k, ∀ b : B, + P (algebraMap (MvPolynomial (Fin n) k) B a * b) = + algebraMap (MvPolynomial (Fin n) k) B a * P b := by + intro a + induction a using MvPolynomial.induction_on with + | C c => + intro b + have hc : algebraMap (MvPolynomial (Fin n) k) B (MvPolynomial.C c) = + algebraMap k B c := by + calc + algebraMap (MvPolynomial (Fin n) k) B (MvPolynomial.C c) = + algebraMap (MvPolynomial (Fin n) k) B + (algebraMap k (MvPolynomial (Fin n) k) c) := by + rw [MvPolynomial.algebraMap_eq] + _ = algebraMap k B c := by + exact (IsScalarTower.algebraMap_apply k + (MvPolynomial (Fin n) k) B c).symm + rw [hc] + simpa [Algebra.smul_def] using P.map_smul c b + | add a a' ha ha' => + intro b + simp only [map_add, map_mul, ha b, ha' b, add_mul] + | mul_X a i ha => + intro b + calc + P (algebraMap _ B (a * MvPolynomial.X i) * b) = + P (algebraMap (MvPolynomial (Fin n) k) B a * + (algebraMap (MvPolynomial (Fin n) k) B (MvPolynomial.X i) * b)) := by + rw [map_mul (algebraMap (MvPolynomial (Fin n) k) B)] + simp [mul_assoc] + _ = algebraMap _ B a * + P (algebraMap _ B (MvPolynomial.X i) * b) := ha _ + _ = algebraMap _ B a * + (algebraMap _ B (MvPolynomial.X i) * P b) := by + rw [hcoord] + _ = algebraMap _ B (a * MvPolynomial.X i) * P b := by + rw [map_mul (algebraMap (MvPolynomial (Fin n) k) B)] + simp [mul_assoc] + apply LinearMap.ext + intro b + obtain ⟨⟨a, s⟩, hs⟩ := IsLocalization.surj S b + have hsa : IsUnit (algebraMap (MvPolynomial (Fin n) k) B (s : _)) := + IsLocalization.map_units B s + refine hsa.mul_left_cancel ?_ + simp only [multiplication_apply] + rw [← hpoly (s : MvPolynomial (Fin n) k) b] + rw [← mul_comm b, hs] + have ha1 : P (algebraMap (MvPolynomial (Fin n) k) B a) = + algebraMap (MvPolynomial (Fin n) k) B a * P 1 := by + simpa using hpoly a 1 + rw [ha1] + rw [← hs] + simp [mul_assoc, mul_comm, mul_left_comm] + +end +end AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialDerivations.lean b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialDerivations.lean new file mode 100644 index 0000000000..66fc22a4f7 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/DifferentialOperators/LocalizedPolynomialDerivations.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Etale.Kaehler +import Mathlib.RingTheory.Kaehler.Polynomial +import Mathlib.RingTheory.Derivation.Lie + +/-! +# Derivations through localizations + +The differentials of a localization are obtained by formally-etale base +change. This file records the resulting extension operation and its +specialization to the partial derivations of a polynomial ring. +-/ + +namespace AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations + +open TensorProduct + +noncomputable section + +universe u + +variable (k A B : Type u) +variable [CommRing k] [CommRing A] [CommRing B] +variable [Algebra k A] [Algebra k B] [Algebra A B] +variable [IsScalarTower k A B] + +/-- Extend a `k`-derivation through a localization `A → B`, by the +formally-etale base-change equivalence for Kähler differentials. -/ +noncomputable def extendDerivation + (S : Submonoid A) [IsLocalization S B] + (D : Derivation k A B) : Derivation k B B := by + letI : Algebra.FormallyEtale A B := + Algebra.FormallyEtale.of_isLocalization (Rₘ := B) S + let base : B ⊗[A] KaehlerDifferential k A →ₗ[B] B := + D.liftKaehlerDifferential.liftBaseChange B + let pull : KaehlerDifferential k B →ₗ[B] B := + base.comp + (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale + k A B).symm.toLinearMap + exact KaehlerDifferential.linearMapEquivDerivation k B pull + +@[simp] +theorem extendDerivation_compAlgebraMap + (S : Submonoid A) [IsLocalization S B] + (D : Derivation k A B) : + (extendDerivation k A B S D).compAlgebraMap A = D := by + letI : Algebra.FormallyEtale A B := + Algebra.FormallyEtale.of_isLocalization (Rₘ := B) S + apply Derivation.ext + intro a + simp [extendDerivation, + KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_symm_D_algebraMap, + Derivation.liftKaehlerDifferential_comp_D] + +/-- A derivation of a localization is uniquely determined by its restriction +to the original algebra. -/ +theorem derivation_ext_of_compAlgebraMap_eq + (S : Submonoid A) [IsLocalization S B] + {D₁ D₂ : Derivation k B B} + (h : D₁.compAlgebraMap A = D₂.compAlgebraMap A) : + D₁ = D₂ := by + letI : Algebra.FormallyEtale A B := + Algebra.FormallyEtale.of_isLocalization (Rₘ := B) S + let e := KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale k A B + have hbase : + (D₁.liftKaehlerDifferential.restrictScalars A).comp + (KaehlerDifferential.map k k A B) = + (D₂.liftKaehlerDifferential.restrictScalars A).comp + (KaehlerDifferential.map k k A B) := by + apply Derivation.liftKaehlerDifferential_unique + apply Derivation.ext + intro x + simpa [KaehlerDifferential.map_D, + Derivation.liftKaehlerDifferential_comp_D] using + Derivation.congr_fun h x + have hpull : + D₁.liftKaehlerDifferential.comp e.toLinearMap = + D₂.liftKaehlerDifferential.comp e.toLinearMap := by + apply LinearMap.ext + intro z + induction z using TensorProduct.induction_on with + | zero => simp + | add x y hx hy => simp only [map_add, hx, hy] + | tmul a x => + simp only [e, + KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_apply, + KaehlerDifferential.mapBaseChange_tmul, + LinearMap.comp_apply, LinearEquiv.coe_coe, LinearMap.map_smul] + exact congrArg (a • ·) (LinearMap.congr_fun hbase x) + apply Derivation.ext + intro x + have hmaps : D₁.liftKaehlerDifferential = D₂.liftKaehlerDifferential := by + apply LinearMap.ext + intro w + obtain ⟨z, rfl⟩ := e.surjective w + exact LinearMap.congr_fun hpull z + simpa [Derivation.liftKaehlerDifferential_comp_D] using + LinearMap.congr_fun hmaps (KaehlerDifferential.D k B x) + +section Polynomial + +variable {k : Type u} {n : ℕ} [Field k] + +/-- The polynomial ring in `n` coordinate variables over `k`. -/ +abbrev PolynomialRing := MvPolynomial (Fin n) k + +private theorem pderiv_comm (i j : Fin n) (f : MvPolynomial (Fin n) k) : + MvPolynomial.pderiv i (MvPolynomial.pderiv j f) = + MvPolynomial.pderiv j (MvPolynomial.pderiv i f) := by + induction f using MvPolynomial.induction_on with + | C c => simp + | add p q hp hq => simp [hp, hq] + | mul_X p l hp => + by_cases hij : i = j + · subst j + simp [hp, mul_comm] + · by_cases hil : i = l + · subst l + by_cases hjl : j = i + · exact False.elim (hij hjl.symm) + · simp [MvPolynomial.pderiv_mul, hp, hjl, hij, mul_comm] <;> ring + · by_cases hjl : j = l + · subst l + simp [MvPolynomial.pderiv_mul, hp, hil, hij, mul_comm] <;> ring + · simp [MvPolynomial.pderiv_mul, hp, hil, hjl, hij, mul_comm] <;> ring + +/-- The `i`th polynomial partial derivative, transported to a localization. -/ +noncomputable def localizedPderiv + (S : Submonoid (PolynomialRing (k := k) (n := n))) + (B : Type u) [CommRing B] + [Algebra (PolynomialRing (k := k) (n := n)) B] + [Algebra k B] + [IsScalarTower k (PolynomialRing (k := k) (n := n)) B] + [IsLocalization S B] (i : Fin n) : Derivation k B B := + extendDerivation k _ B S + ((Algebra.linearMap _ B).compDer (MvPolynomial.pderiv i)) + +@[simp] +theorem localizedPderiv_compAlgebraMap + (S : Submonoid (PolynomialRing (k := k) (n := n))) + (B : Type u) [CommRing B] + [Algebra (PolynomialRing (k := k) (n := n)) B] + [Algebra k B] + [IsScalarTower k (PolynomialRing (k := k) (n := n)) B] + [IsLocalization S B] (i : Fin n) : + (localizedPderiv S B i).compAlgebraMap _ = + (Algebra.linearMap _ B).compDer (MvPolynomial.pderiv i) := by + exact extendDerivation_compAlgebraMap k _ B S _ + +theorem localizedPderiv_apply_algebraMap_X + (S : Submonoid (PolynomialRing (k := k) (n := n))) + (B : Type u) [CommRing B] + [Algebra (PolynomialRing (k := k) (n := n)) B] + [Algebra k B] + [IsScalarTower k (PolynomialRing (k := k) (n := n)) B] + [IsLocalization S B] (i j : Fin n) : + localizedPderiv S B i + (algebraMap (PolynomialRing (k := k) (n := n)) B + (MvPolynomial.X j : PolynomialRing (k := k) (n := n))) = + if i = j then 1 else 0 := by + rw [show algebraMap _ B (MvPolynomial.X j) = + (IsScalarTower.toAlgHom k _ B) (MvPolynomial.X j) by rfl] + have h := Derivation.congr_fun + (localizedPderiv_compAlgebraMap (k := k) S B i) + (MvPolynomial.X j) + change localizedPderiv S B i (algebraMap _ B (MvPolynomial.X j)) = _ at h + simpa [MvPolynomial.pderiv_X, Pi.single_apply, eq_comm] using h + +theorem localizedPderiv_comm + (S : Submonoid (PolynomialRing (k := k) (n := n))) + (B : Type u) [CommRing B] + [Algebra (PolynomialRing (k := k) (n := n)) B] + [Algebra k B] + [IsScalarTower k (PolynomialRing (k := k) (n := n)) B] + [IsLocalization S B] (i j : Fin n) : + (localizedPderiv S B i).toLinearMap.comp + (localizedPderiv S B j).toLinearMap = + (localizedPderiv S B j).toLinearMap.comp + (localizedPderiv S B i).toLinearMap := by + have hcomm : ⁅localizedPderiv S B i, localizedPderiv S B j⁆ = 0 := by + apply derivation_ext_of_compAlgebraMap_eq k _ B S + apply Derivation.ext + intro f + change localizedPderiv S B i (localizedPderiv S B j + (algebraMap _ B f)) - localizedPderiv S B j (localizedPderiv S B i + (algebraMap _ B f)) = 0 + have hi := Derivation.congr_fun + (localizedPderiv_compAlgebraMap (k := k) S B i) f + have hj := Derivation.congr_fun + (localizedPderiv_compAlgebraMap (k := k) S B j) f + change localizedPderiv S B i (algebraMap _ B f) = _ at hi + change localizedPderiv S B j (algebraMap _ B f) = _ at hj + change localizedPderiv S B i (algebraMap _ B f) = + algebraMap _ B (MvPolynomial.pderiv i f) at hi + change localizedPderiv S B j (algebraMap _ B f) = + algebraMap _ B (MvPolynomial.pderiv j f) at hj + rw [hj, hi] + have hij := Derivation.congr_fun + (localizedPderiv_compAlgebraMap (k := k) S B i) + (MvPolynomial.pderiv j f) + have hji := Derivation.congr_fun + (localizedPderiv_compAlgebraMap (k := k) S B j) + (MvPolynomial.pderiv i f) + change localizedPderiv S B i + (algebraMap _ B (MvPolynomial.pderiv j f)) = _ at hij + change localizedPderiv S B j + (algebraMap _ B (MvPolynomial.pderiv i f)) = _ at hji + change localizedPderiv S B i + (algebraMap _ B (MvPolynomial.pderiv j f)) = + algebraMap _ B (MvPolynomial.pderiv i (MvPolynomial.pderiv j f)) at hij + change localizedPderiv S B j + (algebraMap _ B (MvPolynomial.pderiv i f)) = + algebraMap _ B (MvPolynomial.pderiv j (MvPolynomial.pderiv i f)) at hji + rw [hij, hji] + rw [pderiv_comm i j f] + simp + apply LinearMap.ext + intro x + have hx := congrArg (fun d : Derivation k B B => d x) hcomm + exact sub_eq_zero.mp (by simpa [Derivation.commutator_apply, + LinearMap.comp_apply] using hx) + +end Polynomial + +end +end AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/FieldTheory/FunctionField.lean b/LeanPool/Stafford38/AlgebraicAnalysis/FieldTheory/FunctionField.lean new file mode 100644 index 0000000000..985bf1de15 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/FieldTheory/FunctionField.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra +import Mathlib.RingTheory.FiniteType +import Mathlib.RingTheory.Localization.FractionRing + +/-! +# Finitely generated fraction fields + +A fraction field of a finitely generated domain is finitely generated as a +field extension. The conclusion uses `IntermediateField.FG`, rather than +finite type as an algebra: a transcendental fraction field is generally not +finitely generated as an algebra over its ground field. +-/ + +namespace AlgebraicAnalysis.FunctionField + +noncomputable section + +universe u v w + +/-- The fraction field of a finitely generated domain is a finitely generated +field extension of the ground field. -/ +@[nolint unusedArguments] +theorem top_fg_of_finiteType_fractionRing + (k : Type u) (A : Type v) (K : Type w) + [Field k] [CommRing A] [IsDomain A] [Algebra k A] + [Field K] [Algebra A K] [IsFractionRing A K] + [Algebra k K] [IsScalarTower k A K] + [Algebra.FiniteType k A] : + (⊤ : IntermediateField k K).FG := by + classical + obtain ⟨s, hs⟩ := (Algebra.FiniteType.out (R := k) (A := A)) + let f : A →ₐ[k] K := IsScalarTower.toAlgHom k A K + let fi : A ↪ K := + ⟨f, IsFractionRing.injective A K⟩ + let T : IntermediateField k K := + IntermediateField.adjoin k (f '' (s : Set A)) + have hmap : ∀ a : A, f a ∈ T := by + intro a + have ha : a ∈ Algebra.adjoin k (s : Set A) := by + rw [hs] + trivial + refine Algebra.adjoin_induction + (p := fun a _ ↦ f a ∈ T) ?_ ?_ ?_ ?_ ha + · intro x hx + exact IntermediateField.subset_adjoin k _ ⟨x, hx, rfl⟩ + · intro x + simpa [f] using T.algebraMap_mem x + · intro x y _ _ hx hy + simpa using T.add_mem hx hy + · intro x y _ _ hx hy + simpa using T.mul_mem hx hy + have htop : T = ⊤ := by + rw [eq_top_iff] + intro z _ + obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := A) z + rw [← hab] + exact T.div_mem (hmap a) (hmap b) + refine ⟨s.map fi, ?_⟩ + simpa [T, fi, f, Finset.coe_map] using htop + + +end + +end AlgebraicAnalysis.FunctionField diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/LinearAlgebra/FiniteTaylorReconstruction.lean b/LeanPool/Stafford38/AlgebraicAnalysis/LinearAlgebra/FiniteTaylorReconstruction.lean new file mode 100644 index 0000000000..81b22210e3 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/LinearAlgebra/FiniteTaylorReconstruction.lean @@ -0,0 +1,284 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Module.LinearMap.End +import Mathlib.Data.Nat.Factorial.Cast +import Mathlib.Data.Nat.Choose.Basic +import Mathlib.Tactic + +/-! +# Finite Taylor reconstruction + +Application-independent finite Taylor reconstruction for a nilpotent +endomorphism. Extracted from Stafford38 commit c8a513d553b24c7c08da82f496c44dbbaeb1f2fc. +-/ + +namespace AlgebraicAnalysis.FiniteTaylorReconstruction + +open scoped BigOperators + +variable {𝕜 : Type*} [Field 𝕜] [CharZero 𝕜] +variable {V : Type*} [AddCommGroup V] [Module 𝕜 V] + +/-- The finite alternating Taylor projector associated with two endomorphisms. -/ +def projectorMapG (K : ℕ) (S D : V →ₗ[𝕜] V) : V →ₗ[𝕜] V := + ∑ r ∈ Finset.range (K + 1), + ((-1 : 𝕜) ^ r / (r.factorial : 𝕜)) • (S ^ r * D ^ r) + +omit [CharZero 𝕜] in +private lemma projectorMap_term_all + (K j : ℕ) (S D : V →ₗ[𝕜] V) (x : V) : + ((S ^ j * projectorMapG K S D * D ^ j) x) = + ∑ r ∈ Finset.range (K + 1), + ((-1 : 𝕜) ^ r / (r.factorial : 𝕜)) • + ((S ^ (j + r) * D ^ (j + r)) x) := by + unfold projectorMapG + simp only [Finset.mul_sum, Finset.sum_mul, Finset.sum_apply, + smul_mul_assoc, mul_smul_comm, smul_add, Module.End.mul_apply] + rw [LinearMap.sum_apply] + apply Finset.sum_congr rfl + intro r hr + change ((-1 : 𝕜) ^ r / (r.factorial : 𝕜)) • + ((S ^ j * (S ^ r * D ^ r) * D ^ j) x) = + ((-1 : 𝕜) ^ r / (r.factorial : 𝕜)) • + ((S ^ (j + r) * D ^ (j + r)) x) + congr 1 + change ((S ^ j * (S ^ r * D ^ r) * D ^ j) x) = _ + calc + (S ^ j * (S ^ r * D ^ r) * D ^ j) x = + ((S ^ j * S ^ r) * (D ^ r * D ^ j)) x := by + congr 1 + _ = (S ^ (j + r) * D ^ (r + j)) x := by + rw [← pow_add, ← pow_add] + _ = (S ^ (j + r) * D ^ (j + r)) x := by + rw [Nat.add_comm r j] + +private lemma triangular_reindex_all {α : Type*} [AddCommMonoid α] + (K : ℕ) (f : ℕ → ℕ → α) : + (∑ j ∈ Finset.range (K + 1), + ∑ r ∈ Finset.range (K + 1 - j), f j r) = + ∑ q ∈ Finset.range (K + 1), + ∑ j ∈ Finset.range (q + 1), f j (q - j) := by + let s : Finset (Σ _ : ℕ, ℕ) := + (Finset.range (K + 1)).sigma (fun j => Finset.range (K + 1 - j)) + let t : Finset (Σ _ : ℕ, ℕ) := + (Finset.range (K + 1)).sigma (fun q => Finset.range (q + 1)) + have hs : + (∑ j ∈ Finset.range (K + 1), + ∑ r ∈ Finset.range (K + 1 - j), f j r) = + ∑ a ∈ s, f a.1 a.2 := by + dsimp [s] + rw [Finset.sum_sigma'] + have ht : + (∑ q ∈ Finset.range (K + 1), + ∑ j ∈ Finset.range (q + 1), f j (q - j)) = + ∑ a ∈ t, f a.2 (a.1 - a.2) := by + dsimp [t] + rw [Finset.sum_sigma'] + rw [hs, ht] + apply Finset.sum_bij (fun a ha => ⟨a.1 + a.2, a.1⟩) ?_ ?_ ?_ ?_ + · intro a ha + rw [Finset.mem_sigma] at ha ⊢ + constructor + · simp only [Finset.mem_range] + have ha1 : a.1 < K + 1 := Finset.mem_range.mp ha.1 + have ha2 : a.2 < K + 1 - a.1 := Finset.mem_range.mp ha.2 + omega + · simp only [Finset.mem_range] + omega + · intro a₁ ha₁ a₂ ha₂ h + simp only [Sigma.mk.inj_iff] at h + rcases h with ⟨hsum, hfirst⟩ + have hfirst' : a₁.1 = a₂.1 := eq_of_heq hfirst + apply Sigma.ext + · exact hfirst' + · simpa [hfirst'] using (show a₁.2 = a₂.2 from by omega) + · intro b hb + rw [Finset.mem_sigma] at hb + use ⟨b.2, b.1 - b.2⟩ + have hsrc : (⟨b.2, b.1 - b.2⟩ : Σ _ : ℕ, ℕ) ∈ s := by + rw [Finset.mem_sigma] + constructor + · have hbq : b.1 < K + 1 := Finset.mem_range.mp hb.1 + have hbj : b.2 < b.1 + 1 := Finset.mem_range.mp hb.2 + simpa only [Finset.mem_range] using (show b.2 < K + 1 by omega) + · simp only [Finset.mem_range] + have hbq : b.1 < K + 1 := Finset.mem_range.mp hb.1 + have hbj : b.2 < b.1 + 1 := Finset.mem_range.mp hb.2 + omega + refine ⟨hsrc, ?_⟩ + apply Sigma.ext + · change b.2 + (b.1 - b.2) = b.1 + have hbj : b.2 ≤ b.1 := Nat.le_of_lt_succ (Finset.mem_range.mp hb.2) + omega + · simp + · intro a ha + simp + +omit [CharZero 𝕜] in +private lemma alternating_choose_sum (q : ℕ) : + (∑ j ∈ Finset.range (q + 1), + ((-1 : 𝕜) ^ (q - j) * (q.choose j : 𝕜))) = + if q = 0 then 1 else 0 := by + have h := add_pow (1 : 𝕜) (-1 : 𝕜) q + rw [show (1 : 𝕜) + (-1 : 𝕜) = 0 by norm_num] at h + simp only [one_pow, one_mul] at h + by_cases hq : q = 0 + · subst q + norm_num at h ⊢ + · simp [hq] at h ⊢ + simpa [mul_comm] using h.symm + +private lemma reciprocal_binomial_term (q j : ℕ) (hjq : j ≤ q) : + (1 / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜)) = + (1 / (q.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) * (q.choose j : 𝕜)) := by + have hfac : q.choose j * j.factorial * (q - j).factorial = q.factorial := + Nat.choose_mul_factorial_mul_factorial hjq + have hfacQ : (q.choose j : 𝕜) * (j.factorial : 𝕜) * + ((q - j).factorial : 𝕜) = (q.factorial : 𝕜) := by + exact_mod_cast hfac + have hjfac : (j.factorial : 𝕜) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero j + have hqfac : (q.factorial : 𝕜) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero q + have hqjfac : ((q - j).factorial : 𝕜) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero (q - j) + have hrec : + (1 / (j.factorial : 𝕜)) * (1 / ((q - j).factorial : 𝕜)) = + (q.choose j : 𝕜) / (q.factorial : 𝕜) := by + field_simp + rw [← hfacQ] + ring + calc + (1 / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜)) = + ((-1 : 𝕜) ^ (q - j)) * + ((1 / (j.factorial : 𝕜)) * (1 / ((q - j).factorial : 𝕜))) := by + ring + _ = ((-1 : 𝕜) ^ (q - j)) * + ((q.choose j : 𝕜) / (q.factorial : 𝕜)) := by rw [hrec] + _ = (1 / (q.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) * (q.choose j : 𝕜)) := by ring + +private lemma reciprocal_binomial_sum (q : ℕ) : + (∑ j ∈ Finset.range (q + 1), + (1 / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) = + if q = 0 then 1 else 0 := by + rw [show (∑ j ∈ Finset.range (q + 1), + (1 / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) = + ∑ j ∈ Finset.range (q + 1), + (1 / (q.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) * (q.choose j : 𝕜)) by + apply Finset.sum_congr rfl + intro j hj + exact reciprocal_binomial_term q j + (Nat.le_of_lt_succ (Finset.mem_range.mp hj))] + rw [← Finset.mul_sum] + rw [alternating_choose_sum] + by_cases hq : q = 0 + · simp [hq] + · simp [hq] + +omit [CharZero 𝕜] in +private lemma projectorMap_term_trim + (K j : ℕ) (S D : V →ₗ[𝕜] V) (x : V) + (hj : j ≤ K) (hnil : (D ^ (K + 1)) x = 0) : + ((S ^ j * projectorMapG K S D * D ^ j) x) = + ∑ r ∈ Finset.range (K + 1 - j), + ((-1 : 𝕜) ^ r / (r.factorial : 𝕜)) • + ((S ^ (j + r) * D ^ (j + r)) x) := by + rw [projectorMap_term_all] + symm + apply Finset.sum_subset + · intro r hr + exact Finset.mem_range.mpr (by + have hr' := Finset.mem_range.mp hr + omega) + · intro r hrbig hrsmall + have hrbig' := Finset.mem_range.mp hrbig + have hrsmall' : K + 1 - j ≤ r := by + exact Nat.le_of_not_gt (fun hlt => hrsmall (Finset.mem_range.mpr hlt)) + have hpow : (D ^ (j + r)) x = 0 := by + apply Module.End.pow_map_zero_of_le (m := x) (k := K + 1) (l := j + r) + · omega + · exact hnil + simp [Module.End.mul_apply, hpow] + +/-- The all-order finite Taylor reconstruction for a nilpotent derivative. -/ +theorem reconstruction_all + (K : ℕ) (S D : V →ₗ[𝕜] V) (x : V) + (hnil : (D ^ (K + 1)) x = 0) : + x = + ∑ j ∈ Finset.range (K + 1), + ((1 : 𝕜) / (j.factorial : 𝕜)) • + ((S ^ j * projectorMapG K S D * D ^ j) x) := by + have hexpand : + (∑ j ∈ Finset.range (K + 1), + ((1 : 𝕜) / (j.factorial : 𝕜)) • + ((S ^ j * projectorMapG K S D * D ^ j) x)) = + ∑ j ∈ Finset.range (K + 1), + ∑ r ∈ Finset.range (K + 1 - j), + (((1 : 𝕜) / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ r / (r.factorial : 𝕜))) • + ((S ^ (j + r) * D ^ (j + r)) x) := by + apply Finset.sum_congr rfl + intro j hj + have hjK : j ≤ K := Nat.le_of_lt_succ (Finset.mem_range.mp hj) + rw [projectorMap_term_trim K j S D x hjK hnil] + rw [Finset.smul_sum] + apply Finset.sum_congr rfl + intro r hr + rw [smul_smul] + rw [hexpand, triangular_reindex_all] + have hreindex : + (∑ q ∈ Finset.range (K + 1), + ∑ j ∈ Finset.range (q + 1), + (((1 : 𝕜) / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) • + ((S ^ (j + (q - j)) * D ^ (j + (q - j))) x)) = + ∑ q ∈ Finset.range (K + 1), + ∑ j ∈ Finset.range (q + 1), + (((1 : 𝕜) / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) • + ((S ^ q * D ^ q) x) := by + apply Finset.sum_congr rfl + intro q hq + apply Finset.sum_congr rfl + intro j hj + have hjq : j ≤ q := Nat.le_of_lt_succ (Finset.mem_range.mp hj) + rw [Nat.add_sub_of_le hjq] + rw [hreindex] + have hcollapse : + (∑ q ∈ Finset.range (K + 1), + ∑ j ∈ Finset.range (q + 1), + (((1 : 𝕜) / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) • + ((S ^ q * D ^ q) x)) = x := by + -- The inner scalar convolution is the inverse factorial binomial sum. + -- The remaining q=0 term is exactly x; all q>0 terms are zero. + have hterm (q : ℕ) : + (∑ j ∈ Finset.range (q + 1), + (((1 : 𝕜) / (j.factorial : 𝕜)) * + ((-1 : 𝕜) ^ (q - j) / ((q - j).factorial : 𝕜))) • + ((S ^ q * D ^ q) x)) = + (if q = 0 then (1 : 𝕜) else 0) • ((S ^ q * D ^ q) x) := by + rw [← Finset.sum_smul] + rw [reciprocal_binomial_sum] + simp_rw [hterm] + simp + exact hcollapse.symm + +/-! +The following wrapper turns the endomorphism statement into the concrete +algebraic form used in a Weyl chart. It deliberately stops at the abstract +ring/module interface: the A₂-specific work of constructing `s`, proving +`D s = 1`, and proving nilpotence on the chosen element remains external. +-/ +end AlgebraicAnalysis.FiniteTaylorReconstruction diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizationModuleComparison.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizationModuleComparison.lean new file mode 100644 index 0000000000..d897cc6084 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizationModuleComparison.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Localization.Module +import Mathlib.RingTheory.Localization.LocalizationLocalization + +/-! +# Comparison of base and coefficient localizations + +For an `R`-algebra `C`, localizing a `C`-module at the image of a submonoid +`S ≤ R` agrees with localizing it as an `R`-module at `S`. +-/ + +namespace AlgebraicAnalysis.BaseLocalizationModuleComparison + +noncomputable section + +variable {R C E : Type*} +variable [CommRing R] [CommRing C] [Algebra R C] +variable [AddCommGroup E] [Module R E] [Module C E] +variable [IsScalarTower R C E] + +variable (S : Submonoid R) + +local notation "SC" => Algebra.algebraMapSubmonoid C S + +/-- The coefficient-algebra denominator induced by a base denominator. -/ +def coefficientDenominator (s : S) : SC := + ⟨algebraMap R C s, ⟨s, s.property, rfl⟩⟩ + +local instance : IsScalarTower R C (LocalizedModule SC E) where + smul_assoc r c p := by + induction p with + | _ m s => + simp [LocalizedModule.smul'_mk, Algebra.smul_def, mul_smul, + IsScalarTower.algebraMap_smul C] + +theorem localizedModule_isLocalizedOverBase : + IsLocalizedModule S + ((LocalizedModule.mkLinearMap SC E).restrictScalars R) := by + let : IsLocalizedModule (Algebra.algebraMapSubmonoid C S) + (LocalizedModule.mkLinearMap SC E) := by + infer_instance + exact IsLocalizedModule.restrictScalars S (LocalizedModule.mkLinearMap SC E) + +@[nolint unusedArguments] +theorem localizedModule_isLocalizedOverCoefficient : + IsLocalizedModule SC (LocalizedModule.mkLinearMap SC E) := by + infer_instance + +/-- The localized coefficient module viewed over the base localization. -/ +local instance localizedBaseModule : + Module (Localization S) (LocalizedModule SC E) := + Module.compHom _ (algebraMap (Localization S) (Localization SC)) + +local instance : IsScalarTower R (Localization S) (LocalizedModule SC E) := by + constructor + intro r x p + simp only [Algebra.smul_def] + rw [mul_smul] + change algebraMap (Localization S) (Localization SC) + (algebraMap R (Localization S) r) • + algebraMap (Localization S) (Localization SC) x • p = r • + algebraMap (Localization S) (Localization SC) x • p + rw [← IsScalarTower.algebraMap_apply R (Localization S) (Localization SC), + IsScalarTower.algebraMap_smul (Localization SC)] + +/-- The canonical equivalence between base and coefficient localizations. -/ +noncomputable def localizedModuleComparison : + LocalizedModule S E ≃ₗ[Localization S] LocalizedModule SC E := + let : IsLocalizedModule S + ((LocalizedModule.mkLinearMap SC E).restrictScalars R) := + localizedModule_isLocalizedOverBase S + (IsLocalizedModule.linearEquiv S + (LocalizedModule.mkLinearMap S E) + ((LocalizedModule.mkLinearMap SC E).restrictScalars R)).extendScalarsOfIsLocalization + S (Localization S) + +@[simp, nolint simpNF] theorem localizedModuleComparison_mkLinearMap (m : E) : + localizedModuleComparison S (LocalizedModule.mkLinearMap S E m) = + LocalizedModule.mkLinearMap SC E m := by + let : IsLocalizedModule S + ((LocalizedModule.mkLinearMap SC E).restrictScalars R) := + localizedModule_isLocalizedOverBase S + exact IsLocalizedModule.linearEquiv_apply S + (LocalizedModule.mkLinearMap S E) + ((LocalizedModule.mkLinearMap SC E).restrictScalars R) m + +@[simp] theorem localizedModuleComparison_mk (m : E) (s : S) : + localizedModuleComparison S (LocalizedModule.mk m s) = + (LocalizedModule.mk m (coefficientDenominator (C := C) S s) : + LocalizedModule SC E) := by + have h : LocalizedModule.mk m s = + Localization.mk (1 : R) s • LocalizedModule.mkLinearMap S E m := by + rw [LocalizedModule.mkLinearMap_apply, LocalizedModule.mk_smul_mk] + simp + rw [h, map_smul, localizedModuleComparison_mkLinearMap] + change algebraMap (Localization S) (Localization SC) (Localization.mk 1 s) • + (LocalizedModule.mk m (1 : SC) : LocalizedModule SC E) = _ + rw [Localization.mk_eq_mk', + IsLocalization.algebraMap_mk' (R := R) (S := C) + (Rₘ := Localization S) (Sₘ := Localization SC)] + have hs : (⟨algebraMap R C s, + Algebra.mem_algebraMapSubmonoid_of_mem s⟩ : SC) = + coefficientDenominator (C := C) S s := Subtype.ext rfl + rw [map_one, hs] + rw [← Localization.mk_eq_mk', LocalizedModule.mk_smul_mk] + simp + +theorem localizedModuleComparison_natural + {F : Type*} [AddCommGroup F] [Module R F] [Module C F] + [IsScalarTower R C F] (f : E →ₗ[C] F) (x : LocalizedModule S E) : + localizedModuleComparison S + (LocalizedModule.map S (f.restrictScalars R) x) = + LocalizedModule.map SC f (localizedModuleComparison S x) := by + induction x with + | _ m s => simp + +end + +end AlgebraicAnalysis.BaseLocalizationModuleComparison diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizedKoszulPositivity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizedKoszulPositivity.lean new file mode 100644 index 0000000000..467de590b4 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/BaseLocalizedKoszulPositivity.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizationModuleComparison +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulMinimalSupportPositivity + +namespace AlgebraicAnalysis.BaseLocalizedKoszulPositivity + +open scoped Pointwise +open AlgebraicAnalysis +open AlgebraicAnalysis.BaseLocalizationModuleComparison +open AlgebraicAnalysis.LocalizedKernelCokernelEquivalences +open AlgebraicAnalysis.LocalizedMinimalSupportAvoidance +open AlgebraicAnalysis.PrincipalKoszulMinimalSupportPositivity + +noncomputable section + +variable {R C E : Type*} [CommRing R] [CommRing C] [Algebra R C] +variable [AddCommGroup E] [Module R E] [Module C E] [IsScalarTower R C E] +variable [IsNoetherianRing R] [IsNoetherianRing C] [Module.Finite C E] + +theorem localized_length_cokernel_gt_kernel + (x : C) + [Module.Finite R + (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R))] + [Module.Finite R + (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R))] + (q : PrimeSpectrum R) + (hqmem : q ∈ Module.support R + (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R))) + (hqmin : ∀ p ∈ Module.support R + (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R)), + p.asIdeal ≤ q.asIdeal → q.asIdeal ≤ p.asIdeal) + (havoid : ∀ p ∈ (Module.annihilator C E).minimalPrimes, x ∉ p) : + Module.length (Localization q.asIdeal.primeCompl) + (LocalizedModule q.asIdeal.primeCompl + (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R))) > + Module.length (Localization q.asIdeal.primeCompl) + (LocalizedModule q.asIdeal.primeCompl + (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R))) := by + let S : Submonoid R := q.asIdeal.primeCompl + let SC : Submonoid C := Algebra.algebraMapSubmonoid C S + let fC : Module.End C E := LinearMap.lsmul C E x + let fR : Module.End R E := fC.restrictScalars R + have hfinite := localized_kernel_and_cokernel_isFiniteLength fC q hqmem hqmin + have hcokerfinite : IsFiniteLength (Localization S) + (LocalizedModule S (E ⧸ LinearMap.range fR)) := by + simpa only [S, fR, fC] using hfinite.1 + have hkerfinite : IsFiniteLength (Localization S) + (LocalizedModule S (LinearMap.ker fR)) := by + simpa only [S, fR, fC] using hfinite.2 + let : Module (Localization S) (LocalizedModule SC E) := + Module.compHom _ (algebraMap (Localization S) (Localization SC)) + let : IsScalarTower (Localization S) (Localization SC) + (LocalizedModule SC E) := + IsScalarTower.of_compHom (Localization S) (Localization SC) + (LocalizedModule SC E) + let e : LocalizedModule S E ≃ₗ[Localization S] LocalizedModule SC E := + localizedModuleComparison S + let gR : Module.End (Localization S) (LocalizedModule S E) := localizedMap S fR + let y : Localization SC := algebraMap C (Localization SC) x + let gC : Module.End (Localization SC) (LocalizedModule SC E) := + LinearMap.lsmul (Localization SC) (LocalizedModule SC E) y + have heq (z : LocalizedModule S E) : e (gR z) = gC (e z) := by + rw [show e (gR z) = LocalizedModule.map SC fC (e z) by + exact localizedModuleComparison_natural S fC z] + induction e z using LocalizedModule.induction_on with + | _ m s => simp [gC, y, fC, LocalizedModule.smul'_mk] + let ek : LinearMap.ker gR ≃ₗ[Localization S] + LinearMap.ker (gC.restrictScalars (Localization S)) := + LinearEquiv.ofBijective + (e.toLinearMap.domRestrict (LinearMap.ker gR) |>.codRestrict + (LinearMap.ker (gC.restrictScalars (Localization S))) (fun z => by + exact LinearMap.mem_ker.mpr (by simpa using (heq z).symm))) + (by + constructor + · intro a b hab + exact Subtype.ext (e.injective (congrArg Subtype.val hab)) + · intro z + refine ⟨⟨e.symm z, ?_⟩, Subtype.ext (e.apply_symm_apply z)⟩ + exact LinearMap.mem_ker.mpr (e.injective (by + rw [heq] + simpa using z.property))) + have herange : Submodule.map e.toLinearMap (LinearMap.range gR) = + LinearMap.range (gC.restrictScalars (Localization S)) := by + ext z + constructor + · rintro ⟨_, ⟨a, rfl⟩, rfl⟩ + exact ⟨e a, by simpa using (heq a).symm⟩ + · rintro ⟨a, rfl⟩ + refine ⟨gR (e.symm a), ⟨e.symm a, rfl⟩, ?_⟩ + simpa using heq (e.symm a) + let ec : (LocalizedModule S E ⧸ LinearMap.range gR) ≃ₗ[Localization S] + (LocalizedModule SC E ⧸ LinearMap.range + (gC.restrictScalars (Localization S))) := + Submodule.Quotient.equiv _ _ e herange + have hnontrivBase : Nontrivial + (LocalizedModule S (E ⧸ LinearMap.range fR)) := + Module.mem_support_iff.mp (by simpa only [S, fR, fC] using hqmem) + have hnontrivCokerR : Nontrivial + (LocalizedModule S E ⧸ LinearMap.range gR) := + not_subsingleton_iff_nontrivial.mp (by + intro hs + let := hs + have : Subsingleton (LocalizedModule S (E ⧸ LinearMap.range fR)) := + (localizedCokernelEquiv S fR).toEquiv.subsingleton_congr.mpr inferInstance + exact not_subsingleton_iff_nontrivial.mpr hnontrivBase inferInstance) + have hnontrivCokerC : Nontrivial + (LocalizedModule SC E ⧸ LinearMap.range + (gC.restrictScalars (Localization S))) := + not_subsingleton_iff_nontrivial.mp (by + intro hs + exact not_subsingleton_iff_nontrivial.mpr hnontrivCokerR + (ec.toEquiv.subsingleton_congr.mpr hs)) + have hrange : LinearMap.range gC = y • (⊤ : Submodule (Localization SC) + (LocalizedModule SC E)) := by + ext z + rw [LinearMap.mem_range, Submodule.mem_smul_pointwise_iff_exists] + simp only [Submodule.mem_top, true_and] + rfl + have hnontrivQuot : Nontrivial (QuotSMulTop y (LocalizedModule SC E)) := by + change Nontrivial (LocalizedModule SC E ⧸ + y • (⊤ : Submodule (Localization SC) (LocalizedModule SC E))) + rw [← hrange] + exact hnontrivCokerC + have havoid' := localized_minimalPrime_avoids SC x havoid + have hkbase : IsFiniteLength (Localization S) (LinearMap.ker gR) := + (localizedKernelEquiv S fR).isFiniteLength hkerfinite + have hkfinite : IsFiniteLength (Localization S) + (LinearMap.ker (gC.restrictScalars (Localization S))) := + ek.isFiniteLength hkbase + have hpos := length_cokernel_gt_kernel_of_minimal_support + (R := Localization S) (C := Localization SC) (E := LocalizedModule SC E) + y havoid' hnontrivQuot hkfinite + rw [← ec.length_eq, ← (localizedCokernelEquiv S fR).length_eq, + ← ek.length_eq, ← (localizedKernelEquiv S fR).length_eq] at hpos + simpa only [S, fR, fC] using hpos + + +end +end AlgebraicAnalysis.BaseLocalizedKoszulPositivity diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/CommutingPolynomialAction.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/CommutingPolynomialAction.lean new file mode 100644 index 0000000000..864f4a5b2c --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/CommutingPolynomialAction.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.MvPolynomial.Eval + +/-! +# Polynomial actions generated by a commuting family of endomorphisms + +The target of `MvPolynomial.aeval` is required to be commutative. A family of +pairwise commuting endomorphisms therefore gives an evaluation map by first +landing in the commutative subalgebra which it generates. +-/ + +open scoped IsMulCommutative + +namespace AlgebraicAnalysis.CommutingPolynomialAction + +universe u v w z + +variable {k : Type u} [CommRing k] +variable {V : Type v} [AddCommGroup V] [Module k V] + +private theorem range_commutative (v : σ → Module.End k V) + (hcomm : ∀ i j, Commute (v i) (v j)) : + ∀ x ∈ Set.range v, ∀ y ∈ Set.range v, x * y = y * x := by + rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ + exact (hcomm i j).eq + +/-- Evaluation of multivariate polynomials at a pairwise commuting family of +endomorphisms. -/ +noncomputable def commutingPolynomialAction {σ : Type w} + (v : σ → Module.End k V) + (hcomm : ∀ i j, Commute (v i) (v j)) : + MvPolynomial σ k →ₐ[k] Module.End k V := by + let S : Subalgebra k (Module.End k V) := Algebra.adjoin k (Set.range v) + letI : IsMulCommutative S := + Algebra.isMulCommutative_adjoin k (range_commutative v hcomm) + exact + (S.val).comp + (MvPolynomial.aeval (fun i => + ⟨v i, Algebra.subset_adjoin ⟨i, rfl⟩⟩)) + +@[simp] theorem commutingPolynomialAction_apply_X {σ : Type w} + (v : σ → Module.End k V) (hcomm : ∀ i j, Commute (v i) (v j)) (i : σ) : + commutingPolynomialAction v hcomm (MvPolynomial.X i) = v i := by + classical + simp [commutingPolynomialAction] + +/-- Evaluation sends constants to scalar endomorphisms. This named +compatibility lemma is retained even though generic algebra-hom simplification +can also discharge its left-hand side. -/ +@[simp, nolint simpNF] theorem commutingPolynomialAction_apply_C {σ : Type w} + (v : σ → Module.End k V) (hcomm : ∀ i j, Commute (v i) (v j)) (a : k) : + commutingPolynomialAction v hcomm (MvPolynomial.C a) = algebraMap k (Module.End k V) a := by + classical + simp [commutingPolynomialAction] + +theorem commutingPolynomialAction_intertwines {σ : Type w} + {W : Type z} [AddCommGroup W] [Module k W] + (v : σ → Module.End k V) (w : σ → Module.End k W) + (hv : ∀ i j, Commute (v i) (v j)) + (hw : ∀ i j, Commute (w i) (w j)) + (f : V →ₗ[k] W) + (hgen : ∀ i, f.comp (v i) = (w i).comp f) (p : MvPolynomial σ k) : + f.comp (commutingPolynomialAction v hv p) = + (commutingPolynomialAction w hw p).comp f := by + classical + induction p using MvPolynomial.induction_on with + | C a => + apply LinearMap.ext + intro x + simp only [LinearMap.comp_apply, commutingPolynomialAction_apply_C] + change f (a • x) = a • f x + exact f.map_smul a x + | add p q hp hq => + rw [map_add, map_add, LinearMap.comp_add, LinearMap.add_comp, hp, hq] + | mul_X p i hp => + apply LinearMap.ext + intro x + simp only [map_mul, LinearMap.comp_apply, Module.End.mul_apply, + commutingPolynomialAction_apply_X] + calc + f ((commutingPolynomialAction v hv p) (v i x)) = + (commutingPolynomialAction w hw p) (f (v i x)) := + congrArg (fun g : V →ₗ[k] W => g (v i x)) hp + _ = (commutingPolynomialAction w hw p) (w i (f x)) := by + have hgi := congrArg (fun g : V →ₗ[k] W => g x) (hgen i) + change f (v i x) = w i (f x) at hgi + rw [hgi] + +/-- The polynomial action as a module structure on the original space. -/ +noncomputable def commutingPolynomialModule {σ : Type w} + (v : σ → Module.End k V) (hcomm : ∀ i j, Commute (v i) (v j)) : + Module (MvPolynomial σ k) V := + Module.compHom V (commutingPolynomialAction v hcomm).toRingHom + +end AlgebraicAnalysis.CommutingPolynomialAction diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/DenominatorTorsion.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/DenominatorTorsion.lean new file mode 100644 index 0000000000..f628b9cf41 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/DenominatorTorsion.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Generic denominator clearing and torsion quotients + +This is the unconditional part of packet 9. It separates the algebraic +quotient argument from the still-unformalized triangular PBW reduction. An +explicit clearing witness for each vector implies torsion of the quotient; +the principal right-ideal case is proved directly from the opposite Ore +condition. No stage freeness or noncommutative flatness is postulated. +-/ + +namespace AlgebraicAnalysis +namespace DenominatorTorsion + +open nonZeroDivisors +open MulOpposite + +universe u v + +section AbstractClearance + +variable {R : Type u} [Ring R] +variable {M : Type v} [AddCommGroup M] [Module Rᵐᵒᵖ M] + +/-- Right-module torsion, with the right scalar displayed as `op s`. -/ +def IsTorsionRight : Prop := + ∀ m : M, ∃ s : R, s ≠ 0 ∧ (op s) • m = 0 + +/-- A denominator-clearing witness for a right submodule quotient. -/ +def HasDenominatorClearance (N : Submodule Rᵐᵒᵖ M) : Prop := + ∀ m : M, ∃ s : R, s ≠ 0 ∧ (op s) • m ∈ N + +theorem quotient_isTorsion_of_clearance + (N : Submodule Rᵐᵒᵖ M) + (hclear : HasDenominatorClearance (R := R) N) : + IsTorsionRight (R := R) (M := M ⧸ N) := by + intro z + refine Submodule.Quotient.induction_on N z ?_ + intro m + rcases hclear m with ⟨s, hs, hsm⟩ + refine ⟨s, hs, ?_⟩ + change N.mkQ ((op s) • m) = 0 + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact hsm + +end AbstractClearance + +section PrincipalRightIdeal + +variable {R : Type u} [Ring R] [Nontrivial R] [NoZeroDivisors R] +variable [OreLocalization.OreSet (Rᵐᵒᵖ)⁰] + +/-- Left multiplication by `q` is a right-`R`-linear map. -/ +def leftMulLinear (q : R) : R →ₗ[Rᵐᵒᵖ] R where + toFun x := q * x + map_add' x y := by + change q * (x + y) = q * x + q * y + rw [mul_add] + map_smul' a x := by + change q * (x * (unop a)) = (q * x) * (unop a) + rw [mul_assoc] + +/-- The right ideal `qR`, represented as the range of left multiplication. -/ +def principalRightIdeal (q : R) : Submodule Rᵐᵒᵖ R := + LinearMap.range (leftMulLinear q) + +@[nolint unusedArguments] +theorem principalRightIdeal_mem (q x : R) : + q * x ∈ principalRightIdeal q := by + exact ⟨x, rfl⟩ + +theorem principal_quotient_isTorsion (q : R) (hq : q ≠ 0) : + IsTorsionRight (R := R) + (M := R ⧸ principalRightIdeal q) := by + intro z + refine Submodule.Quotient.induction_on (principalRightIdeal q) z ?_ + intro x + let qop : (Rᵐᵒᵖ)⁰ := + ⟨op q, mem_nonZeroDivisors_iff_ne_zero.mpr (by simpa using hq)⟩ + rcases OreLocalization.oreCondition (op x) qop with ⟨num, den, hOre⟩ + let denR : R := unop (den : Rᵐᵒᵖ) + have hOre' : x * denR = q * unop num := by + have h := congrArg unop hOre + simpa only [unop_mul, unop_op, denR, qop] using h + refine ⟨denR, ?_, ?_⟩ + · intro hden + have hden' : (den : Rᵐᵒᵖ) = 0 := by + apply unop_injective + simpa [denR] using hden + exact (nonZeroDivisors.coe_ne_zero den) hden' + change (principalRightIdeal q).mkQ ((op denR) • x) = 0 + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + refine ⟨unop num, ?_⟩ + change q * unop num = x * denR + exact hOre'.symm + +end PrincipalRightIdeal + + +end DenominatorTorsion +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupport.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupport.lean new file mode 100644 index 0000000000..4909677ca2 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupport.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Support +import Mathlib.RingTheory.Noetherian.Orzech + +/-! +# Kernel support is contained in cokernel support + +The only input is the Hopfian property of a finite module over a commutative +Noetherian ring. The proof is deliberately made at a prime, using the +actual `LocalizedModule` support definition. +-/ + +namespace AlgebraicAnalysis + +theorem endomorphism_kernel_support_subset_cokernel_support + {R E : Type*} [CommRing R] [AddCommGroup E] [Module R E] + [IsNoetherianRing R] [Module.Finite R E] (f : Module.End R E) : + Module.support R (LinearMap.ker f) ⊆ + Module.support R (E ⧸ LinearMap.range f) := by + intro p hp + rw [Module.mem_support_iff'] at hp ⊢ + by_contra h + have hnot : p ∉ Module.support R (E ⧸ LinearMap.range f) := by + rw [Module.mem_support_iff'] + exact h + have h := Module.notMem_support_iff.mp hnot + have hsurj : Function.Surjective + (LocalizedModule.map p.asIdeal.primeCompl f) := + (LinearMap.localizedMap_surjective_iff_subsingleton_localized_coker + p.asIdeal.primeCompl f).2 h + let : IsNoetherian (Localization p.asIdeal.primeCompl) + (LocalizedModule p.asIdeal.primeCompl E) := by infer_instance + have hinj : Function.Injective + (LocalizedModule.map p.asIdeal.primeCompl f) := + IsNoetherian.injective_of_surjective_endomorphism _ hsurj + obtain ⟨x, hx⟩ := hp + let x' : LocalizedModule p.asIdeal.primeCompl E := + LocalizedModule.mk x.1 1 + have hxzero : x' = 0 := by + apply hinj + dsimp [x'] + rw [LocalizedModule.map_mk] + simp [LinearMap.mem_ker.mp x.2] + have hxzero' : + IsLocalizedModule.mk' (LocalizedModule.mkLinearMap p.asIdeal.primeCompl E) + x.1 (1 : p.asIdeal.primeCompl) = 0 := by + rw [← IsLocalizedModule.mk_eq_mk'] + exact hxzero + obtain ⟨s, hs⟩ := + (IsLocalizedModule.mk'_eq_zero' + (LocalizedModule.mkLinearMap p.asIdeal.primeCompl E) (1 : p.asIdeal.primeCompl)).mp + hxzero' + have hs' : (s.1 : R) • x = 0 := by + apply Subtype.ext + exact hs + exact hx s.1 s.2 hs' + +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupportOverBase.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupportOverBase.lean new file mode 100644 index 0000000000..734aa3527d --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EndomorphismKernelSupportOverBase.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupport +import Mathlib.RingTheory.Ideal.Maps + +/-! +# Kernel support over a base ring + +A finite module over a commutative Noetherian coefficient algebra is Hopfian +over that algebra. This gives the kernel--cokernel support inclusion after +restriction of scalars, without assuming finite generation over the base. +-/ + +namespace AlgebraicAnalysis + +theorem endomorphism_kernel_support_subset_cokernel_support_over_base + {R C E : Type*} [CommRing R] [CommRing C] [Algebra R C] + [AddCommGroup E] [Module C E] [Module R E] [IsScalarTower R C E] + [IsNoetherianRing C] [Module.Finite C E] (f : Module.End C E) : + Module.support R (LinearMap.ker (f.restrictScalars R)) ⊆ + Module.support R (E ⧸ LinearMap.range (f.restrictScalars R)) := by + intro p hp + rw [Module.mem_support_iff_exists_annihilator] at hp ⊢ + obtain ⟨x, hx⟩ := hp + let xC : LinearMap.ker f := ⟨x.1, by + exact x.2⟩ + let I : Ideal C := (C ∙ xC).annihilator + have hdisj : Disjoint (I : Set C) (p.asIdeal.primeCompl.map (algebraMap R C)) := by + rw [Set.disjoint_left] + rintro c hc ⟨r, hr, rfl⟩ + have hc' : algebraMap R C r • xC.1 = 0 := by + have hcx : algebraMap R C r • xC = 0 := by + exact (Submodule.mem_annihilator_span_singleton _ _).mp hc + exact congrArg Subtype.val hcx + have hrx : r • x = 0 := by + apply Subtype.ext + change r • x.1 = 0 + simpa [xC, IsScalarTower.algebraMap_smul C r x.1] using hc' + have hrann : r ∈ (R ∙ x).annihilator := by + exact (Submodule.mem_annihilator_span_singleton _ _).mpr hrx + exact hr (hx hrann) + obtain ⟨q, hqprime, hIq, hqdisj⟩ := I.exists_le_prime_disjoint _ hdisj + let q' : PrimeSpectrum C := ⟨q, hqprime⟩ + have hxC : q' ∈ Module.support C (LinearMap.ker f) := by + rw [Module.mem_support_iff_exists_annihilator] + exact ⟨xC, show (C ∙ xC).annihilator ≤ q from hIq⟩ + have hcokerC : q' ∈ Module.support C (E ⧸ LinearMap.range f) := + endomorphism_kernel_support_subset_cokernel_support f hxC + obtain ⟨y, hy⟩ := Module.mem_support_iff_exists_annihilator.mp hcokerC + refine ⟨y, ?_⟩ + intro r hr + have hmap : algebraMap R C r ∈ (C ∙ y).annihilator := by + rw [Submodule.mem_annihilator_span_singleton] + have hry : r • y = 0 := + (Submodule.mem_annihilator_span_singleton _ _).mp hr + simpa [IsScalarTower.algebraMap_smul C r y] using hry + by_contra hrp + exact Set.disjoint_left.mp hqdisj (hy hmap) ⟨r, hrp, rfl⟩ + + +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeAssembly.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeAssembly.lean new file mode 100644 index 0000000000..6119b8acad --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeAssembly.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EscapeSpan + +/-! +# Finite-tuple central-coordinate escape + +This is the finite-dimensional algebraic part of packet 7. A tuple of +coefficient-left PBW terms with strictly decreasing active degrees is assumed +to lie in a right `S`-submodule. If the submodule is also closed under left +multiplication by the central coordinate, the commutator iterates isolate +one coordinate at a time. `Escape.ad_unit_production` supplies the unit at +the selected coordinate, and the right-module lemma in `EscapeSpan` then +gives the whole free module. + +The theorem deliberately stops at this local span result. It does not claim +that a global Stafford correction family supplies the hypotheses. +-/ + +namespace AlgebraicAnalysis.EscapeAssembly + +open AlgebraicAnalysis.Escape +open AlgebraicAnalysis.EscapeSpan + +noncomputable section + +open scoped BigOperators +open Polynomial + +variable {E S : Type*} [DivisionRing E] [CharZero E] [Ring S] +variable {n : ℕ} + +lemma iterate_commutatorVector_mem + (H : Submodule Sᵐᵒᵖ (Fin n → S)) (x : S) + (hleft : ∀ v : Fin n → S, v ∈ H → (fun i => x * v i) ∈ H) + {v : Fin n → S} (hv : v ∈ H) (k : ℕ) : + (commutatorVector x)^[k] v ∈ H := by + induction k with + | zero => simpa using hv + | succ k ih => + rw [Function.iterate_succ_apply'] + exact commutatorVector_mem H x hleft ih + +/-- Coordinates whose index is below the current active degree. -/ +def knownCoordinates (m : ℕ) : Finset (Fin n) := + Finset.univ.filter (fun j => j.val < m) + +/-- Remove the currently known coordinate contributions from a vector. -/ +def residualVector (v : Fin n → S) (m : ℕ) : Fin n → S := + v - ∑ j ∈ knownCoordinates m, Pi.single j (v j) + +lemma residualVector_apply_lt (v : Fin n → S) (m : ℕ) + {j : Fin n} (hj : j.val < m) : residualVector v m j = 0 := by + classical + simp only [residualVector, Pi.sub_apply] + have hmem : j ∈ knownCoordinates m := by simp [knownCoordinates, hj] + have hsum : + (∑ k ∈ knownCoordinates m, + (Pi.single k (v k) : Fin n → S)) j = v j := by + rw [Finset.sum_apply] + rw [Finset.sum_eq_single j] + · simp + · intro b hb hbj + simp [Ne.symm hbj] + · intro hjnot + exact (hjnot hmem).elim + rw [hsum, sub_self] + +lemma residualVector_apply_not_lt (v : Fin n → S) (m : ℕ) + {j : Fin n} (hj : ¬ j.val < m) : residualVector v m j = v j := by + classical + simp only [residualVector, Pi.sub_apply] + have hsum : + (∑ k ∈ knownCoordinates m, + (Pi.single k (v k) : Fin n → S)) j = 0 := by + rw [Finset.sum_apply] + apply Finset.sum_eq_zero + intro k hk + have hkj : k ≠ j := by + intro hEq + subst j + exact hj (by simpa [knownCoordinates] using hk) + simp [hkj] + rw [hsum, sub_zero] + +/-- +The actual finite-tuple escape theorem. The only analytic-looking input is +the PBW transport packaged by `CentralEscapeData`; all module operations are +right-sided through `Sᵐᵒᵖ`. +-/ +theorem finite_tuple_escape + (D : CentralEscapeData (E := E) (S := S)) + (p : Fin n → Polynomial E) + (hp : ∀ i, p i ≠ 0) + (hstrict : StrictAnti (fun i => (p i).natDegree)) + (H : Submodule Sᵐᵒᵖ (Fin n → S)) + (hv : (fun i => D.normal (p i)) ∈ H) + (hleft : ∀ v : Fin n → S, v ∈ H → + (fun i => D.embed D.coordinate * v i) ∈ H) : + H = ⊤ := by + let v : Fin n → S := fun i => D.normal (p i) + have hv' : v ∈ H := hv + have hpure : ∀ i : Fin n, ∃ u : S, IsUnit u ∧ + (Pi.single i u : Fin n → S) ∈ H := by + have hprocess : ∀ m : ℕ, m ≤ n → + ∀ j : Fin n, j.val < m → ∃ u : S, IsUnit u ∧ + (Pi.single j u : Fin n → S) ∈ H := by + intro m hm + induction m with + | zero => + intro j hj + omega + | succ m ih => + have hm' : m < n := by omega + let i : Fin n := ⟨m, hm'⟩ + have hprior : ∀ j : Fin n, j.val < m → ∃ u : S, IsUnit u ∧ + (Pi.single j u : Fin n → S) ∈ H := by + intro j hj + exact ih (by omega) j hj + have hsum : + (∑ j ∈ knownCoordinates m, (Pi.single j (v j) : Fin n → S)) ∈ H := by + apply H.sum_mem + intro j hj + have hjlt : j.val < m := by + simpa [knownCoordinates] using hj + obtain ⟨u, hu, huH⟩ := hprior j hjlt + exact single_mem_of_unit_single_mem H j hu huH (v j) + have hres : residualVector v m ∈ H := + H.sub_mem hv' hsum + have hzmem : + (commutatorVector (D.embed D.coordinate))^[((p i).natDegree)] + (residualVector v m) ∈ H := + iterate_commutatorVector_mem H (D.embed D.coordinate) hleft hres _ + let z : Fin n → S := + (commutatorVector (D.embed D.coordinate))^[((p i).natDegree)] + (residualVector v m) + have hzi : IsUnit (z i) := by + dsimp [z] + rw [commutatorVector_iterate_apply] + rw [residualVector_apply_not_lt] + · simpa [v] using D.ad_unit_production (hp i) + · exact Nat.not_lt_of_ge (Nat.le_refl m) + have hzj : ∀ j : Fin n, j ≠ i → z j = 0 := by + intro j hji + by_cases hjlt : j.val < m + · dsimp [z] + rw [commutatorVector_iterate_apply, + residualVector_apply_lt v m hjlt] + simp + · have hjval : j.val ≠ m := by + intro hEq + apply hji + apply Fin.ext + exact hEq + have hmj : m < j.val := by omega + have hij : i < j := by + exact Fin.mk_lt_mk.mpr hmj + have hdeg : (p j).natDegree < (p i).natDegree := + hstrict hij + have hzero : + (derivative^[((p i).natDegree)]) (p j) = 0 := + iterate_derivative_eq_zero hdeg + dsimp [z] + rw [commutatorVector_iterate_apply, + residualVector_apply_not_lt v m hjlt] + rw [D.iterate_commutator_normal, hzero] + simp + have hzpure : z = Pi.single i (z i) := by + funext j + by_cases hji : i = j + · subst j + simp + · rw [hzj j (Ne.symm hji)] + simp [hji] + have hpure_i : (Pi.single i (z i) : Fin n → S) ∈ H := by + rw [← hzpure] + exact hzmem + intro j hj + by_cases hEq : j.val = m + · have hji : j = i := by + apply Fin.ext + exact hEq + subst j + exact ⟨z i, hzi, hpure_i⟩ + · have hjlt : j.val < m := by omega + exact hprior j hjlt + intro i + have hi : i.val + 1 ≤ n := by exact i.isLt.succ_le + exact hprocess (i.val + 1) hi i (by simp) + exact top_of_unit_singletons H hpure + + +end +end AlgebraicAnalysis.EscapeAssembly diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeSpan.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeSpan.lean new file mode 100644 index 0000000000..b9fa14f26a --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/EscapeSpan.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Derivation.Escape + +/-! +# Right-sided span consequences of escape + +The preceding file proves the scalar/unit-production kernel. This file +records the next unconditional module step, with right-sided order visible: +the free module `Fin n → S` is regarded as a left module over `Sᵐᵒᵖ`, so +scalar multiplication by `op a` is right multiplication by `a` in `S`. + +No claim is made here that a particular escape family produces the pure +coordinate vectors. That is the remaining Stafford correction construction. +-/ + +namespace AlgebraicAnalysis.EscapeSpan + +open AlgebraicAnalysis.Escape + +noncomputable section + +variable {S : Type*} [Ring S] {n : ℕ} + +/-- Coordinatewise right multiplication in the free right `S`-module. -/ +def rightMulVector (v : Fin n → S) (a : S) : Fin n → S := + fun i => v i * a + +@[simp] theorem rightMulVector_apply (v : Fin n → S) (a : S) (i : Fin n) : + rightMulVector v a i = v i * a := rfl + +@[simp] theorem op_smul_vector (v : Fin n → S) (a : S) : + (MulOpposite.op a : Sᵐᵒᵖ) • v = rightMulVector v a := by + rfl + +/-- Coordinatewise commutator with the distinguished escape coordinate. -/ +def commutatorVector (x : S) (v : Fin n → S) : Fin n → S := + fun i => commutator x (v i) + +@[simp] theorem commutatorVector_apply (x : S) (v : Fin n → S) (i : Fin n) : + commutatorVector x v i = commutator x (v i) := rfl + +@[simp] theorem commutatorVector_iterate_apply (x : S) (v : Fin n → S) + (k : ℕ) (i : Fin n) : + (commutatorVector x)^[k] v i = + (commutator x)^[k] (v i) := by + induction k with + | zero => rfl + | succ k ih => + calc + ((commutatorVector x)^[k.succ] v) i = + commutatorVector x ((commutatorVector x)^[k] v) i := by + rw [Function.iterate_succ_apply'] + _ = commutator x (((commutatorVector x)^[k] v) i) := rfl + _ = commutator x ((commutator x)^[k] (v i)) := + congrArg (commutator x) (ih) + _ = ((commutator x)^[k.succ]) (v i) := by + rw [Function.iterate_succ_apply'] + +/-/ The left action needed to close a right submodule under `adₓ`. -/ +theorem commutatorVector_mem + (H : Submodule Sᵐᵒᵖ (Fin n → S)) (x : S) + (hleft : ∀ v : Fin n → S, v ∈ H → (fun i => x * v i) ∈ H) + {v : Fin n → S} (hv : v ∈ H) : + commutatorVector x v ∈ H := by + have hright : rightMulVector v x ∈ H := by + simpa only [op_smul_vector] using + H.smul_mem (MulOpposite.op x) hv + have hleft' : (fun i => x * v i) ∈ H := hleft v hv + change (fun i => v i * x - x * v i) ∈ H + change rightMulVector v x - (fun i => x * v i) ∈ H + exact H.sub_mem hright hleft' + +/-! +The key right-sided module consequence. A unit coordinate can be inverted +on the right, so a pure vector `single i u` gives every `single i a`. +-/ + +theorem single_mem_of_unit_single_mem + (H : Submodule Sᵐᵒᵖ (Fin n → S)) + (i : Fin n) {u : S} (hu : IsUnit u) + (hmem : (Pi.single i u : Fin n → S) ∈ H) (a : S) : + (Pi.single i a : Fin n → S) ∈ H := by + let w : S := (hu.unit⁻¹ : Sˣ) * a + have hsmul := H.smul_mem (MulOpposite.op w) hmem + have hunit : u * (hu.unit⁻¹ : Sˣ) = 1 := hu.mul_val_inv + have hcoord : u * w = a := by + dsimp [w] + rw [← mul_assoc, hunit, one_mul] + have heq : (MulOpposite.op w : Sᵐᵒᵖ) • + (Pi.single i u : Fin n → S) = Pi.single i a := by + funext j + by_cases hji : i = j + · subst j + change (Pi.single i u : Fin n → S) i * w = + (Pi.single i a : Fin n → S) i + simpa only [Pi.single_eq_same] using hcoord + · have hji' : j ≠ i := Ne.symm hji + simp [hji, hji'] + rw [← heq] + exact hsmul + +/-- +If a right `S`-submodule contains a pure unit vector in every coordinate, +then it is the whole free right module. The proof uses the finite standard +basis decomposition and never reverses the right-sided scalar order. +-/ +theorem top_of_unit_singletons + (H : Submodule Sᵐᵒᵖ (Fin n → S)) + (hunit : ∀ i : Fin n, ∃ u : S, IsUnit u ∧ + (Pi.single i u : Fin n → S) ∈ H) : + H = ⊤ := by + apply top_unique + intro v hv + have hsingle : ∀ i : Fin n, + (Pi.single i (v i) : Fin n → S) ∈ H := by + intro i + obtain ⟨u, hu, hmem⟩ := hunit i + exact single_mem_of_unit_single_mem H i hu hmem (v i) + have hdecomp : (∑ i : Fin n, Pi.single i (v i)) = v := by + funext j + simp + rw [← hdecomp] + exact H.sum_mem (fun i _ => hsingle i) + + +end +end AlgebraicAnalysis.EscapeSpan diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredSchreyer.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredSchreyer.lean new file mode 100644 index 0000000000..7fee4fd00a --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredSchreyer.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Exact filtered Schreyer criterion + +This file isolates the abstract equivalence used when a right-linear +presentation is combined with a lower filtration piece. The right action is +encoded by the opposite scalar ring, while the lower piece is only an +additive subgroup. No Ore, Weyl, or characteristic-variety structure is +needed. +-/ + +namespace AlgebraicAnalysis.FilteredSchreyer + +universe u v + +variable {A : Type u} {E : Type v} + [Ring A] [AddCommGroup E] [Module Aᵐᵒᵖ E] + +/-- A right-linear presentation map sends the explicit right action on its +source to right multiplication in the target ring. -/ +theorem map_rightSMul (phi : E →ₗ[Aᵐᵒᵖ] A) (b : E) (x : A) : + phi ((MulOpposite.op x) • b) = phi b * x := by + rw [phi.map_smul, op_smul_eq_mul] + +/-- Exact filtered Schreyer criterion for one distinguished right action. + +The left side says that `C` lies in the image of `phi` modulo the lower +subgroup `L`. The right side expresses the corresponding source relation as +an element mapping into `L`, plus an explicit right multiple of `x`. The +hypotheses separate the two directions: right-coordinate stability is used +forward, and strictness under that coordinate is used backward. -/ +theorem range_add_lower_iff_preimage_add_rightMultiple + (phi : E →ₗ[Aᵐᵒᵖ] A) (L : AddSubgroup A) + (a : E) (C x : A) + (ha : phi a = 1 + C * x) + (hone : (1 : A) ∈ L) + (hLx : ∀ z : A, z ∈ L → z * x ∈ L) + (hstrict : ∀ z : A, z * x ∈ L → z ∈ L) : + (∃ b : E, ∃ l : A, l ∈ L ∧ C = phi b + l) ↔ + ∃ t b : E, phi t ∈ L ∧ + a = t + (MulOpposite.op x) • b := by + constructor + · rintro ⟨b, l, hl, rfl⟩ + let t := a - (MulOpposite.op x) • b + have hphiRight : phi ((MulOpposite.op x) • b) = phi b * x := + map_rightSMul phi b x + have hphit : phi t = 1 + l * x := by + dsimp [t] + rw [map_sub, hphiRight, ha] + noncomm_ring + have htLower : phi t ∈ L := by + rw [hphit] + exact L.add_mem hone (hLx l hl) + refine ⟨t, b, htLower, ?_⟩ + dsimp [t] + abel + · rintro ⟨t, b, htLower, rfl⟩ + have hphiRight : phi ((MulOpposite.op x) • b) = phi b * x := + map_rightSMul phi b x + rw [map_add, hphiRight] at ha + have hCx : C * x = phi t + phi b * x - 1 := by + apply (eq_sub_iff_add_eq).2 + calc + C * x + 1 = 1 + C * x := add_comm _ _ + _ = phi t + phi b * x := ha.symm + have hproduct : (C - phi b) * x = phi t - 1 := by + rw [sub_mul, hCx] + abel + have hproductLower : (C - phi b) * x ∈ L := by + rw [hproduct] + exact L.sub_mem htLower hone + have hlower : C - phi b ∈ L := hstrict _ hproductLower + exact ⟨b, C - phi b, hlower, by abel⟩ + + +end AlgebraicAnalysis.FilteredSchreyer diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredStrictness.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredStrictness.lean new file mode 100644 index 0000000000..fbf4e38045 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredStrictness.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Quotient.Basic + +/-! +# Strict filtered endomorphisms + +A strict surjective endomorphism of a filtered module is surjective on every +subquotient of the filtration. The formulation here uses only submodules and +their quotients; it does not introduce a separate associated-graded framework. +-/ + +namespace AlgebraicAnalysis.FilteredStrictness + +variable {R M : Type*} [Ring R] [AddCommGroup M] [Module R M] + +/-- An endomorphism is strict for `F` when its image of every filtration piece +is the intersection of that piece with its global range. -/ +def IsStrict (F : ℕ → Submodule R M) (f : M →ₗ[R] M) : Prop := + ∀ n, (F n).map f = F n ⊓ LinearMap.range f + +/-- The filtration subquotient `F upper / F lower`, represented inside +`F upper`. The monotonicity assumption identifies the denominator with the +expected copy of `F lower`. -/ +abbrev GradedQuotient (F : ℕ → Submodule R M) (hF : Monotone F) + (lower upper : ℕ) (h : lower ≤ upper) : Type _ := + F upper ⧸ LinearMap.range (Submodule.inclusion (hF h)) + +/-- The endomorphism induced on a filtration subquotient. -/ +def gradedQuotientMap (F : ℕ → Submodule R M) (hF : Monotone F) + (f : M →ₗ[R] M) + (hpres : ∀ n, ∀ x ∈ F n, f x ∈ F n) + (lower upper : ℕ) (h : lower ≤ upper) : + GradedQuotient F hF lower upper h →ₗ[R] + GradedQuotient F hF lower upper h := by + let fUpper : F upper →ₗ[R] F upper := + LinearMap.codRestrict (F upper) (f.domRestrict (F upper)) + (fun x ↦ hpres upper x x.property) + let lowerInUpper : Submodule R (F upper) := + LinearMap.range (Submodule.inclusion (hF h)) + exact lowerInUpper.mapQ lowerInUpper fUpper (by + intro x hx + obtain ⟨y, rfl⟩ := hx + exact ⟨⟨f y, hpres lower y y.property⟩, rfl⟩) + +/-- A globally surjective filtration-preserving strict endomorphism induces a +surjection on every filtration subquotient, hence on each graded piece. -/ +theorem gradedQuotientMap_surjective + (F : ℕ → Submodule R M) (hF : Monotone F) + (f : M →ₗ[R] M) + (hpres : ∀ n, ∀ x ∈ F n, f x ∈ F n) + (hstrict : IsStrict F f) + (hsurj : Function.Surjective f) + (lower upper : ℕ) (h : lower ≤ upper) : + Function.Surjective (gradedQuotientMap F hF f hpres lower upper h) := by + have hmap : ∀ n, (F n).map f = F n := by + intro n + calc + (F n).map f = F n ⊓ LinearMap.range f := hstrict n + _ = F n := by rw [LinearMap.range_eq_top.mpr hsurj]; simp + have hUpper : Function.Surjective + (LinearMap.codRestrict (F upper) (f.domRestrict (F upper)) + (fun x ↦ hpres upper x x.property)) := by + intro y + have hy : (y : M) ∈ (F upper).map f := by + rw [hmap upper] + exact y.property + obtain ⟨x, hx, hxy⟩ := Submodule.mem_map.mp hy + exact ⟨⟨x, hx⟩, Subtype.ext hxy⟩ + intro y + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ y + obtain ⟨x, hx⟩ := hUpper y + refine ⟨Submodule.Quotient.mk x, ?_⟩ + rw [gradedQuotientMap, Submodule.mapQ_apply, hx] + + +end AlgebraicAnalysis.FilteredStrictness diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryExhaustion.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryExhaustion.lean new file mode 100644 index 0000000000..5d353dc4a4 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryExhaustion.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages +import Mathlib.Algebra.DirectSum.Module + +/-! +# Boundary exhaustion on the total target pages + +The concrete boundary inclusions give maps from the first target page to every +later target page. Surjectivity of the underlying differential and exhaustive +filtration imply pointwise eventual vanishing; finite support then gives the +same statement on the external direct sum. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +private theorem boundaries_one_le (r : ℕ) (p : ℤ) : + K.boundaries 1 p ≤ K.boundaries (r + 1) p := by + induction r with + | zero => exact le_rfl + | succ r ihr => + exact ihr.trans (K.boundaries_le_succ (r + 1) p) + +private theorem boundaries_mono {a b : ℕ} (hab : a ≤ b) (p : ℤ) : + K.boundaries a p ≤ K.boundaries b p := by + induction b, hab using Nat.le_induction with + | base => exact le_rfl + | succ b hb ih => exact ih.trans (K.boundaries_le_succ b p) + +/-- The quotient map induced by `B₁ ⊆ B_{r+1}` at one target component. -/ +def targetBoundaryMap (r : ℕ) (p : ℤ) : + K.TargetPage 1 p →ₗ[k] K.TargetPage (r + 1) p := + Submodule.mapQ _ _ LinearMap.id (by + intro x hx + exact K.boundaries_one_le r p hx) + +@[simp] theorem targetBoundaryMap_mk (r : ℕ) (p : ℤ) (x : K.G p) : + K.targetBoundaryMap r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk x := + Submodule.mapQ_apply _ _ _ _ + +theorem targetBoundaryMap_surjective (r : ℕ) (p : ℤ) : + Function.Surjective (K.targetBoundaryMap r p) := by + intro y + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective + ((K.boundaries (r + 1) p).comap (K.G p).subtype) y + exact ⟨Submodule.Quotient.mk x, K.targetBoundaryMap_mk r p x⟩ + +/-- The component kernels grow with the page index. -/ +theorem targetBoundaryMap_ker_mono (r s : ℕ) (hrs : r ≤ s) (p : ℤ) : + LinearMap.ker (K.targetBoundaryMap r p) ≤ + LinearMap.ker (K.targetBoundaryMap s p) := by + intro y hy + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective + ((K.boundaries 1 p).comap (K.G p).subtype) y + change K.targetBoundaryMap r p (Submodule.Quotient.mk x) = 0 at hy + change K.targetBoundaryMap s p (Submodule.Quotient.mk x) = 0 + rw [K.targetBoundaryMap_mk, Submodule.Quotient.mk_eq_zero] at hy ⊢ + have hpage : r + 1 ≤ s + 1 := by omega + exact K.boundaries_mono hpage p hy + +/-- The total target map into page `r+1`. -/ +def totalBoundaryMap (r : ℕ) : + K.TargetTotal 1 →ₗ[k] K.TargetTotal (r + 1) := + DirectSum.lmap (K.targetBoundaryMap r) + +@[simp] theorem totalBoundaryMap_lof (r : ℕ) (p : ℤ) + (x : K.TargetPage 1 p) : + K.totalBoundaryMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage 1 q) p x) = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage (r + 1) q) p + (K.targetBoundaryMap r p x) := by + rw [totalBoundaryMap] + exact DirectSum.lmap_of _ _ _ + +theorem totalBoundaryMap_surjective (r : ℕ) : + Function.Surjective (K.totalBoundaryMap r) := by + apply (DirectSum.lmap_surjective _).mpr + exact K.targetBoundaryMap_surjective r + +theorem totalBoundaryMap_ker_mono (r s : ℕ) (hrs : r ≤ s) : + LinearMap.ker (K.totalBoundaryMap r) ≤ + LinearMap.ker (K.totalBoundaryMap s) := by + intro x hx + apply LinearMap.mem_ker.mpr + apply DirectSum.ext_component k + intro p + have hlocal : K.targetBoundaryMap r p (x p) = 0 := by + apply LinearMap.mem_ker.mp + exact congrArg (fun z => z p) hx + have hker := K.targetBoundaryMap_ker_mono r s hrs p + exact LinearMap.mem_ker.mp (hker (LinearMap.mem_ker.mpr hlocal)) + +private theorem pointwise_boundary_exhaustion + (hG : ∀ z : M, ∃ s : ℤ, z ∈ K.G s) + (hf : Function.Surjective K.f) (p : ℤ) (y : K.TargetPage 1 p) : + ∃ r : ℕ, K.targetBoundaryMap r p y = 0 := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective + ((K.boundaries 1 p).comap (K.G p).subtype) y + obtain ⟨n, hn⟩ := K.exists_mem_boundaries_of_surjective hG hf x.property + let r := n - 1 + have hnr : n ≤ r + 1 := by dsimp [r]; omega + have hbound : K.boundaries n p ≤ K.boundaries (r + 1) p := by + rcases n with _ | n + · exact (K.boundaries_le_succ 0 p).trans (K.boundaries_one_le r p) + · simpa [r] using le_rfl + refine ⟨r, ?_⟩ + rw [K.targetBoundaryMap_mk, Submodule.Quotient.mk_eq_zero] + exact hbound hn + +/-- Every finitely supported total target vector is killed at some page. -/ +theorem totalBoundaryMap_eventually_zero + (hG : ∀ z : M, ∃ s : ℤ, z ∈ K.G s) + (hf : Function.Surjective K.f) (x : K.TargetTotal 1) : + ∃ r : ℕ, K.totalBoundaryMap r x = 0 := by + classical + induction x using DirectSum.induction_on with + | zero => exact ⟨0, by simp⟩ + | of p y => + obtain ⟨r, hr⟩ := K.pointwise_boundary_exhaustion hG hf p y + refine ⟨r, ?_⟩ + rw [show DirectSum.of _ p y = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage 1 q) p y from rfl, + K.totalBoundaryMap_lof, hr] + simp + | add x y hx hy => + obtain ⟨r, hr⟩ := hx + obtain ⟨s, hs⟩ := hy + let t := max r s + refine ⟨t, ?_⟩ + have hrt : r ≤ t := le_max_left _ _ + have hst : s ≤ t := le_max_right _ _ + have hxr := K.totalBoundaryMap_ker_mono r t hrt (LinearMap.mem_ker.mpr hr) + have hys := K.totalBoundaryMap_ker_mono s t hst (LinearMap.mem_ker.mpr hs) + rw [map_add] + rw [LinearMap.mem_ker.mp hxr, LinearMap.mem_ker.mp hys, add_zero] + + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryNaturality.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryNaturality.lean new file mode 100644 index 0000000000..28a13d61b8 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermBoundaryNaturality.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryExhaustion + +/-! +# Naturality of the target boundary maps + +The quotient maps from page one to later target pages commute with every +filtered operator. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +namespace PageOperator + +variable {K} {d : ℤ} (P : K.PageOperator d) + +theorem targetBoundaryMap_naturality (r : ℕ) (p : ℤ) : + K.targetBoundaryMap r (p - d) ∘ₗ P.targetMap 1 p = + P.targetMap (r + 1) p ∘ₗ K.targetBoundaryMap r p := by + apply LinearMap.ext + intro y + refine Submodule.Quotient.induction_on + ((K.boundaries 1 p).comap (K.G p).subtype) y ?_ + intro x + simp only [LinearMap.comp_apply, P.targetMap_mk, K.targetBoundaryMap_mk] + +theorem totalBoundaryMap_naturality (r : ℕ) : + K.totalBoundaryMap r ∘ₗ P.targetTotalMap 1 = + P.targetTotalMap (r + 1) ∘ₗ K.totalBoundaryMap r := by + apply LinearMap.ext + intro x + induction x using DirectSum.induction_on with + | zero => simp + | of p y => + rw [show DirectSum.of (fun q : ℤ => K.TargetPage 1 q) p y = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage 1 q) p y from rfl] + change K.totalBoundaryMap r (P.targetTotalMap 1 + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage 1 q) p y)) = + P.targetTotalMap (r + 1) (K.totalBoundaryMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage 1 q) p y)) + rw [P.targetTotalMap_lof, K.totalBoundaryMap_lof, + K.totalBoundaryMap_lof, P.targetTotalMap_lof] + exact congrArg (fun z => + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage (r + 1) q) (p - d) z) + (LinearMap.congr_fun (P.targetBoundaryMap_naturality r p) y) + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + + +end PageOperator + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageActions.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageActions.lean new file mode 100644 index 0000000000..1129e2980d --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageActions.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages +import Mathlib.LinearAlgebra.Isomorphisms + +/-! +# Filtered operators on two-term pages + +A filtered operator of degree `d` shifts `G p` into `G (p - d)` and commutes +with the two-term differential. This file constructs its maps on the concrete +source and target pages, proves compatibility with `drop`, and proves that an +operator is unchanged on pages after adding one that shifts an additional +filtration level. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +/-- A `k`-linear operator of filtration degree `d` commuting with the +two-term differential. -/ +structure PageOperator (d : ℤ) where + /-- The underlying endomorphism of the filtered module. -/ + g : M →ₗ[k] M + commute : K.f.comp g = g.comp K.f + shift : ∀ p x, x ∈ K.G p → g x ∈ K.G (p - d) + +namespace PageOperator + +variable {K} {d : ℤ} (P : K.PageOperator d) + +/-- Composition of filtered operators. -/ +def comp {e : ℤ} (Q : K.PageOperator e) : K.PageOperator (d + e) where + g := P.g.comp Q.g + commute := by + apply LinearMap.ext + intro x + change K.f (P.g (Q.g x)) = P.g (Q.g (K.f x)) + have hp := LinearMap.congr_fun P.commute (Q.g x) + have hq := LinearMap.congr_fun Q.commute x + change K.f (P.g (Q.g x)) = P.g (K.f (Q.g x)) at hp + change K.f (Q.g x) = Q.g (K.f x) at hq + rw [hp, hq] + shift := by + intro p x hx + have hQ := Q.shift p x hx + have hP := P.shift (p - e) (Q.g x) hQ + simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using hP + +/-- The reverse-order composition, given the same canonical sum degree. -/ +def reverseComp {e : ℤ} (Q : K.PageOperator e) : K.PageOperator (d + e) where + g := Q.g.comp P.g + commute := by + apply LinearMap.ext + intro x + change K.f (Q.g (P.g x)) = Q.g (P.g (K.f x)) + have hq := LinearMap.congr_fun Q.commute (P.g x) + have hp := LinearMap.congr_fun P.commute x + change K.f (Q.g (P.g x)) = Q.g (K.f (P.g x)) at hq + change K.f (P.g x) = P.g (K.f x) at hp + rw [hq, hp] + shift := by + intro p x hx + have hP := P.shift p x hx + have hQ := Q.shift (p - d) (P.g x) hP + simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using hQ + +private theorem coe_castG {p q : ℤ} (h : p = q) (x : K.G p) : + ((h ▸ x : K.G q) : M) = (x : M) := by + subst q + rfl + +theorem commute_apply (x : M) : K.f (P.g x) = P.g (K.f x) := by + exact LinearMap.congr_fun P.commute x + +/-- The restriction of the operator to a source-page cycle numerator. -/ +def sourceRestricted (r : ℕ) (p : ℤ) : + K.cycles r p →ₗ[k] K.cycles r (p - d) := + (P.g.comp (K.cycles r p).subtype).codRestrict (K.cycles r (p - d)) (by + intro x + refine ⟨P.shift p (x : M) x.property.1, ?_⟩ + change K.f (P.g (x : M)) ∈ K.G (p - d + r) + rw [P.commute_apply] + have h := P.shift (p + r) (K.f (x : M)) x.property.2 + have hindex : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + rwa [hindex] at h) + +private theorem sourceRestricted_denominator (r : ℕ) (p : ℤ) : + (K.G (p + 1)).comap (K.cycles r p).subtype ≤ + ((K.G (p - d + 1)).comap (K.cycles r (p - d)).subtype).comap + (P.sourceRestricted r p) := by + intro x hx + change P.g (x : M) ∈ K.G (p - d + 1) + have h := P.shift (p + 1) (x : M) hx + have hindex : p + 1 - d = p - d + 1 := by omega + rwa [hindex] at h + +/-- The operator induced on a source page. -/ +def sourceMap (r : ℕ) (p : ℤ) : + K.SourcePage r p →ₗ[k] K.SourcePage r (p - d) := + Submodule.mapQ _ _ (P.sourceRestricted r p) + (P.sourceRestricted_denominator r p) + +@[simp] theorem sourceMap_mk (r : ℕ) (p : ℤ) (x : K.cycles r p) : + P.sourceMap r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (P.sourceRestricted r p x) := + Submodule.mapQ_apply _ _ _ _ + +/-- Transport between equal source-page indices. -/ +def sourcePageCast (r : ℕ) {p q : ℤ} (h : p = q) : + K.SourcePage r p ≃ₗ[k] K.SourcePage r q := by + subst q + exact LinearEquiv.refl k _ + +@[simp] theorem sourcePageCast_mk (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.cycles r p) : + sourcePageCast (K := K) r h (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (h ▸ x) := by + subst q + rfl + +/-- The restriction of the operator to a target-page filtration piece. -/ +def targetRestricted (p : ℤ) : K.G p →ₗ[k] K.G (p - d) := + (P.g.comp (K.G p).subtype).codRestrict (K.G (p - d)) + (fun x => P.shift p (x : M) x.property) + +private theorem maps_boundaries (r : ℕ) (p : ℤ) {x : M} + (hx : x ∈ K.boundaries r p) : P.g x ∈ K.boundaries r (p - d) := by + rcases Submodule.mem_sup.mp hx with ⟨a, ha, e, he, rfl⟩ + rw [map_add] + apply Submodule.add_mem + · apply Submodule.mem_sup.mpr + refine ⟨P.g a, ⟨P.shift p a ha.1, ?_⟩, 0, Submodule.zero_mem _, by simp⟩ + rcases ha.2 with ⟨z, hz, rfl⟩ + refine ⟨P.g z, ?_, ?_⟩ + · have h := P.shift (p - r + 1) z hz + have hindex : p - (r : ℤ) + 1 - d = p - d - (r : ℤ) + 1 := by omega + rwa [hindex] at h + · exact P.commute_apply z + · apply Submodule.mem_sup.mpr + have h := P.shift (p + 1) e he + have hindex : p + 1 - d = p - d + 1 := by omega + rw [hindex] at h + exact ⟨0, Submodule.zero_mem _, P.g e, h, by simp⟩ + +private theorem targetRestricted_denominator (r : ℕ) (p : ℤ) : + (K.boundaries r p).comap (K.G p).subtype ≤ + ((K.boundaries r (p - d)).comap (K.G (p - d)).subtype).comap + (P.targetRestricted p) := by + intro x hx + exact P.maps_boundaries r p hx + +/-- The operator induced on a target page. -/ +def targetMap (r : ℕ) (p : ℤ) : + K.TargetPage r p →ₗ[k] K.TargetPage r (p - d) := + Submodule.mapQ _ _ (P.targetRestricted p) + (P.targetRestricted_denominator r p) + +@[simp] theorem targetMap_mk (r : ℕ) (p : ℤ) (x : K.G p) : + P.targetMap r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (P.targetRestricted p x) := + Submodule.mapQ_apply _ _ _ _ + +/-- Transport between target-page indices known to be equal. -/ +def targetPageCast (r : ℕ) {p q : ℤ} (h : p = q) : + K.TargetPage r p ≃ₗ[k] K.TargetPage r q := by + subst q + exact LinearEquiv.refl k _ + +@[simp] theorem targetPageCast_mk (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.G p) : + targetPageCast (K := K) r h (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (h ▸ x) := by + subst q + rfl + +private def targetRestrictedAtDrop (r : ℕ) (p : ℤ) : + K.G (p + r) →ₗ[k] K.G (p - d + r) := + (P.g.comp (K.G (p + r)).subtype).codRestrict (K.G (p - d + r)) (by + intro x + have h := P.shift (p + r) (x : M) x.property + have hindex : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + rwa [hindex] at h) + +private theorem targetRestrictedAtDrop_denominator (r : ℕ) (p : ℤ) : + (K.boundaries r (p + r)).comap (K.G (p + r)).subtype ≤ + ((K.boundaries r (p - d + r)).comap (K.G (p - d + r)).subtype).comap + (P.targetRestrictedAtDrop r p) := by + intro x hx + have h := P.maps_boundaries r (p + r) hx + have hindex : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + rwa [hindex] at h + +/-- The target-page operator at the codomain index of `drop`, reindexed by +the identity `(p+r)-d = (p-d)+r`. -/ +def targetMapAtDrop (r : ℕ) (p : ℤ) : + K.TargetPage r (p + r) →ₗ[k] K.TargetPage r (p - d + r) := + Submodule.mapQ _ _ (P.targetRestrictedAtDrop r p) + (P.targetRestrictedAtDrop_denominator r p) + +@[simp] theorem targetMapAtDrop_mk (r : ℕ) (p : ℤ) (x : K.G (p + r)) : + P.targetMapAtDrop r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (P.targetRestrictedAtDrop r p x) := + Submodule.mapQ_apply _ _ _ _ + +/-- `targetMapAtDrop` is the general target-page map followed by the canonical +reindexing isomorphism. -/ +theorem targetMapAtDrop_eq_cast_targetMap (r : ℕ) (p : ℤ) : + P.targetMapAtDrop r p = + (targetPageCast (K := K) r + (by omega : p + (r : ℤ) - d = p - d + (r : ℤ))).toLinearMap.comp + (P.targetMap r (p + r)) := by + let hindex : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + change P.targetMapAtDrop r p = + (targetPageCast (K := K) r hindex).toLinearMap.comp + (P.targetMap r (p + r)) + apply LinearMap.ext + intro y + refine Submodule.Quotient.induction_on + ((K.boundaries r (p + r)).comap (K.G (p + r)).subtype) y ?_ + intro x + rw [P.targetMapAtDrop_mk, LinearMap.comp_apply, P.targetMap_mk] + change Submodule.Quotient.mk (P.targetRestrictedAtDrop r p x) = + targetPageCast (K := K) r _ + (Submodule.Quotient.mk (P.targetRestricted (p + r) x)) + rw [targetPageCast_mk] + congr 1 + apply Subtype.ext + change P.g (x : M) = + ((hindex ▸ P.targetRestricted (p + r) x : K.G (p - d + r)) : M) + rw [coe_castG] + rfl + +/-- The source and reindexed target operator maps commute with the page +differential. -/ +theorem targetMapAtDrop_drop (r : ℕ) (p : ℤ) (x : K.SourcePage r p) : + P.targetMapAtDrop r p (K.drop r p x) = + K.drop r (p - d) (P.sourceMap r p x) := by + refine Submodule.Quotient.induction_on + ((K.G (p + 1)).comap (K.cycles r p).subtype) x ?_ + intro z + rw [K.drop_mk, P.targetMapAtDrop_mk, P.sourceMap_mk, K.drop_mk] + change Submodule.Quotient.mk (⟨P.g (K.f (z : M)), _⟩ : K.G (p - d + r)) = + Submodule.Quotient.mk (⟨K.f (P.g (z : M)), _⟩ : K.G (p - d + r)) + congr 2 + exact (P.commute_apply (z : M)).symm + +/-- Compatibility of the general source and target page maps with `drop`, +with the unavoidable target-index transport made explicit. -/ +theorem targetMap_drop (r : ℕ) (p : ℤ) (x : K.SourcePage r p) : + targetPageCast (K := K) r + (by omega : p + (r : ℤ) - d = p - d + (r : ℤ)) + (P.targetMap r (p + r) (K.drop r p x)) = + K.drop r (p - d) (P.sourceMap r p x) := by + let hindex : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + change ((targetPageCast (K := K) r hindex).toLinearMap.comp + (P.targetMap r (p + r))) (K.drop r p x) = _ + rw [← P.targetMapAtDrop_eq_cast_targetMap r p] + exact P.targetMapAtDrop_drop r p x + +/-- Two degree-`d` operators have the same symbol when their difference shifts +one additional filtration level. -/ +def SameSymbol (Q : K.PageOperator d) : Prop := + ∀ p x, x ∈ K.G p → (P.g - Q.g) x ∈ K.G (p - d + 1) + +theorem sourceMap_eq_of_sameSymbol {Q : K.PageOperator d} + (hPQ : P.SameSymbol Q) (r : ℕ) (p : ℤ) : + P.sourceMap r p = Q.sourceMap r p := by + apply LinearMap.ext + intro y + refine Submodule.Quotient.induction_on + ((K.G (p + 1)).comap (K.cycles r p).subtype) y ?_ + intro x + rw [P.sourceMap_mk, Q.sourceMap_mk] + apply (Submodule.Quotient.eq _).2 + change P.g (x : M) - Q.g (x : M) ∈ K.G (p - d + 1) + simpa using hPQ p (x : M) x.property.1 + +theorem targetMap_eq_of_sameSymbol {Q : K.PageOperator d} + (hPQ : P.SameSymbol Q) (r : ℕ) (p : ℤ) : + P.targetMap r p = Q.targetMap r p := by + apply LinearMap.ext + intro y + refine Submodule.Quotient.induction_on + ((K.boundaries r p).comap (K.G p).subtype) y ?_ + intro x + rw [P.targetMap_mk, Q.targetMap_mk] + apply (Submodule.Quotient.eq _).2 + change P.g (x : M) - Q.g (x : M) ∈ K.boundaries r (p - d) + exact Submodule.mem_sup.mpr + ⟨0, Submodule.zero_mem _, P.g (x : M) - Q.g (x : M), + hPQ p (x : M) x.property, by simp⟩ + +theorem targetMapAtDrop_eq_of_sameSymbol {Q : K.PageOperator d} + (hPQ : P.SameSymbol Q) (r : ℕ) (p : ℤ) : + P.targetMapAtDrop r p = Q.targetMapAtDrop r p := by + rw [P.targetMapAtDrop_eq_cast_targetMap, + Q.targetMapAtDrop_eq_cast_targetMap, + P.targetMap_eq_of_sameSymbol hPQ r (p + r)] + + +end PageOperator + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageEquivalences.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageEquivalences.lean new file mode 100644 index 0000000000..bf8555b178 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPageEquivalences.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages +import Mathlib.LinearAlgebra.Isomorphisms + +/-! +# Successor equivalences for the filtered two-term pages + +This file proves, from the concrete representative definitions in +`FilteredTwoTermPages`, that the next source page is the kernel of the page +differential and that the next target page is its cokernel. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +private abbrev sourceDenominator (r : ℕ) (p : ℤ) : + Submodule k (K.cycles r p) := + (K.G (p + 1)).comap (K.cycles r p).subtype + +private abbrev targetDenominator (r : ℕ) (p : ℤ) : + Submodule k (K.G p) := + (K.boundaries r p).comap (K.G p).subtype + +private def sourceSuccInclusion (r : ℕ) (p : ℤ) : + K.cycles (r + 1) p →ₗ[k] K.cycles r p := + Submodule.inclusion (K.cycles_succ_le r p) + +private theorem sourceSuccInclusion_denominator (r : ℕ) (p : ℤ) : + K.sourceDenominator (r + 1) p ≤ + (K.sourceDenominator r p).comap (K.sourceSuccInclusion r p) := by + intro x hx + exact hx + +/-- The map from the next source page to the current source page. -/ +def sourceSuccMap (r : ℕ) (p : ℤ) : + K.SourcePage (r + 1) p →ₗ[k] K.SourcePage r p := + Submodule.mapQ _ _ (K.sourceSuccInclusion r p) + (K.sourceSuccInclusion_denominator r p) + +@[simp] theorem sourceSuccMap_mk (r : ℕ) (p : ℤ) + (x : K.cycles (r + 1) p) : + K.sourceSuccMap r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (K.sourceSuccInclusion r p x) := + Submodule.mapQ_apply _ _ _ _ + +private theorem drop_sourceSuccMap_eq_zero (r : ℕ) (p : ℤ) + (x : K.SourcePage (r + 1) p) : + K.drop r p (K.sourceSuccMap r p x) = 0 := by + refine Submodule.Quotient.induction_on (K.sourceDenominator (r + 1) p) x ?_ + intro z + rw [K.sourceSuccMap_mk] + exact K.drop_mk_eq_zero_of_mem_cycles_succ r p + (K.sourceSuccInclusion r p z) z.property + +/-- The canonical map from the next source page into the kernel of `d_r`. -/ +def sourceSuccKernelMap (r : ℕ) (p : ℤ) : + K.SourcePage (r + 1) p →ₗ[k] LinearMap.ker (K.drop r p) := + (K.sourceSuccMap r p).codRestrict (LinearMap.ker (K.drop r p)) + (K.drop_sourceSuccMap_eq_zero r p) + +private theorem sourceSuccMap_injective (r : ℕ) (p : ℤ) : + Function.Injective (K.sourceSuccMap r p) := by + intro a b + revert b + refine Submodule.Quotient.induction_on (K.sourceDenominator (r + 1) p) a ?_ + intro x b + refine Submodule.Quotient.induction_on (K.sourceDenominator (r + 1) p) b ?_ + intro y hab + rw [K.sourceSuccMap_mk, K.sourceSuccMap_mk] at hab + apply (Submodule.Quotient.eq (K.sourceDenominator (r + 1) p)).2 + have hmem := + (Submodule.Quotient.eq (K.sourceDenominator r p)).1 hab + exact hmem + +private theorem sourceSuccKernelMap_surjective (r : ℕ) (p : ℤ) : + Function.Surjective (K.sourceSuccKernelMap r p) := by + rintro ⟨y, hy⟩ + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective + (K.sourceDenominator r p) y + have hxzero : K.drop r p (Submodule.Quotient.mk x) = 0 := hy + obtain ⟨z, hz, hxz⟩ := + K.exists_cycles_succ_rep_of_drop_mk_eq_zero r p x hxzero + let w : K.cycles (r + 1) p := ⟨(x : M) - z, hxz⟩ + refine ⟨Submodule.Quotient.mk w, Subtype.ext ?_⟩ + rw [show ((K.sourceSuccKernelMap r p + (Submodule.Quotient.mk w) : LinearMap.ker (K.drop r p)) : + K.SourcePage r p) = K.sourceSuccMap r p (Submodule.Quotient.mk w) from rfl] + rw [K.sourceSuccMap_mk] + apply (Submodule.Quotient.eq (K.sourceDenominator r p)).2 + change ((w : M) - (x : M)) ∈ K.G (p + 1) + simpa [w] using (K.G (p + 1)).neg_mem hz + +/-- On the source, the next page is the kernel of the current page +differential. -/ +noncomputable def sourceSuccEquivKerDrop (r : ℕ) (p : ℤ) : + K.SourcePage (r + 1) p ≃ₗ[k] LinearMap.ker (K.drop r p) := + LinearEquiv.ofBijective (K.sourceSuccKernelMap r p) + ⟨fun _ _ h => K.sourceSuccMap_injective r p (congrArg Subtype.val h), + K.sourceSuccKernelMap_surjective r p⟩ + +/-- The quotient map from a target page to its successor page. -/ +def targetSuccMap (r : ℕ) (p : ℤ) : + K.TargetPage r p →ₗ[k] K.TargetPage (r + 1) p := + Submodule.mapQ _ _ LinearMap.id (by + intro x hx + exact K.boundaries_le_succ r p hx) + +@[simp] private theorem targetSuccMap_mk (r : ℕ) (p : ℤ) + (x : K.G p) : + K.targetSuccMap r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk x := + Submodule.mapQ_apply _ _ _ _ + +theorem targetSuccMap_surjective (r : ℕ) (p : ℤ) : + Function.Surjective (K.targetSuccMap r p) := by + intro y + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective + (K.targetDenominator (r + 1) p) y + exact ⟨Submodule.Quotient.mk x, K.targetSuccMap_mk r p x⟩ + +private theorem targetSuccMap_drop_eq_zero (r : ℕ) (p : ℤ) + (x : K.SourcePage r p) : + K.targetSuccMap r (p + r) (K.drop r p x) = 0 := by + refine Submodule.Quotient.induction_on (K.sourceDenominator r p) x ?_ + intro z + rw [K.drop_mk, K.targetSuccMap_mk, Submodule.Quotient.mk_eq_zero] + change K.f (z : M) ∈ K.boundaries (r + 1) (p + r) + apply Submodule.mem_sup.mpr + refine ⟨K.f (z : M), ⟨z.property.2, ?_⟩, + 0, Submodule.zero_mem _, by simp⟩ + refine ⟨(z : M), ?_, rfl⟩ + have hind : p + (r : ℤ) - ((r + 1 : ℕ) : ℤ) + 1 = p := by + push_cast + omega + rw [hind] + exact z.property.1 + +private theorem range_drop_le_ker_targetSuccMap (r : ℕ) (p : ℤ) : + LinearMap.range (K.drop r p) ≤ + LinearMap.ker (K.targetSuccMap r (p + r)) := by + rintro _ ⟨x, rfl⟩ + exact LinearMap.mem_ker.mpr (K.targetSuccMap_drop_eq_zero r p x) + +private theorem ker_targetSuccMap_le_range_drop (r : ℕ) (p : ℤ) : + LinearMap.ker (K.targetSuccMap r (p + r)) ≤ + LinearMap.range (K.drop r p) := by + intro y hy + change K.targetSuccMap r (p + r) y = 0 at hy + revert hy + refine Submodule.Quotient.induction_on (K.targetDenominator r (p + r)) y ?_ + intro y hy + rw [K.targetSuccMap_mk, Submodule.Quotient.mk_eq_zero] at hy + change (y : M) ∈ K.boundaries (r + 1) (p + r) at hy + obtain ⟨z, hz, e, he, hsum⟩ := K.mem_boundaries_succ_rep r (p + r) hy + have hindex : p + (r : ℤ) - (r : ℤ) = p := by omega + have hzp : z ∈ K.G p := by simpa [hindex] using hz + have he' : e ∈ K.G (p + r) := K.next_le (p + r) he + have hfz : K.f z ∈ K.G (p + r) := by + have : K.f z = (y : M) - e := by rw [hsum]; simp + rw [this] + exact Submodule.sub_mem _ y.property he' + let x : K.cycles r p := ⟨z, hzp, hfz⟩ + refine ⟨Submodule.Quotient.mk x, ?_⟩ + rw [K.drop_mk] + apply (Submodule.Quotient.eq (K.targetDenominator r (p + r))).2 + change K.f z - (y : M) ∈ K.boundaries r (p + r) + have hdifference : K.f z - (y : M) = -e := by + rw [hsum] + abel + rw [hdifference] + apply (K.boundaries r (p + r)).neg_mem + exact Submodule.mem_sup.mpr + ⟨0, Submodule.zero_mem _, e, he, by simp⟩ + +theorem ker_targetSuccMap_eq_range_drop (r : ℕ) (p : ℤ) : + LinearMap.ker (K.targetSuccMap r (p + r)) = + LinearMap.range (K.drop r p) := + le_antisymm (K.ker_targetSuccMap_le_range_drop r p) + (K.range_drop_le_ker_targetSuccMap r p) + +/-- The map from the cokernel of `d_r` to the next target page. -/ +def targetCokernelMap (r : ℕ) (p : ℤ) : + (K.TargetPage r (p + r) ⧸ LinearMap.range (K.drop r p)) →ₗ[k] + K.TargetPage (r + 1) (p + r) := + (LinearMap.range (K.drop r p)).liftQ (K.targetSuccMap r (p + r)) + (K.range_drop_le_ker_targetSuccMap r p) + +private theorem targetCokernelMap_injective (r : ℕ) (p : ℤ) : + Function.Injective (K.targetCokernelMap r p) := by + rw [← LinearMap.ker_eq_bot] + exact Submodule.ker_liftQ_eq_bot _ _ + (K.range_drop_le_ker_targetSuccMap r p) + (K.ker_targetSuccMap_eq_range_drop r p).le + +private theorem targetCokernelMap_surjective (r : ℕ) (p : ℤ) : + Function.Surjective (K.targetCokernelMap r p) := by + intro y + obtain ⟨x, rfl⟩ := K.targetSuccMap_surjective r (p + r) y + exact ⟨Submodule.Quotient.mk x, Submodule.liftQ_apply _ _ _⟩ + +/-- On the target, the next page is the cokernel of the current page +differential. -/ +noncomputable def targetSuccEquivCokerDrop (r : ℕ) (p : ℤ) : + K.TargetPage (r + 1) (p + r) ≃ₗ[k] + K.TargetPage r (p + r) ⧸ LinearMap.range (K.drop r p) := + (LinearEquiv.ofBijective (K.targetCokernelMap r p) + ⟨K.targetCokernelMap_injective r p, + K.targetCokernelMap_surjective r p⟩).symm + + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPages.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPages.lean new file mode 100644 index 0000000000..74519ac23e --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermPages.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Quotient.Basic +import Mathlib.Tactic + +/-! +# Pages of a filtered two-term complex + +This file constructs the `Z_r` and `B_r` subquotients for a two-term filtered +complex. The page differential is induced by the original differential on +representatives; no successor-page equivalence is part of the input. + +We use a decreasing, integer-indexed filtration `G`, as obtained from an +increasing filtration `F` by `G p = F (-p)`. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +/-- A filtration-preserving two-term complex `M --f--> M`. -/ +structure FilteredTwoTerm (k : Type u) (M : Type v) [Ring k] + [AddCommGroup M] [Module k M] where + /-- The decreasing filtration on the underlying module. -/ + G : ℤ → Submodule k M + antitone : Antitone G + /-- The differential of the two-term complex. -/ + f : M →ₗ[k] M + map_le : ∀ p, (G p).map f ≤ G p + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +/-- The numerator of `Z_r` in the source. -/ +def cycles (r : ℕ) (p : ℤ) : Submodule k M := + K.G p ⊓ (K.G (p + r)).comap K.f + +/-- The numerator of `B_r` in the target. -/ +def boundaries (r : ℕ) (p : ℤ) : Submodule k M := + (K.G p ⊓ (K.G (p - r + 1)).map K.f) ⊔ K.G (p + 1) + +theorem next_le (p : ℤ) : K.G (p + 1) ≤ K.G p := + K.antitone (by omega) + +theorem boundaries_le (r : ℕ) (p : ℤ) : K.boundaries r p ≤ K.G p := by + apply sup_le + · exact inf_le_left + · exact K.next_le p + +/-- The actual source page. Using the intersection numerator gives the +canonical model +`(G^p ∩ f⁻¹G^{p+r}) / (G^{p+1} ∩ f⁻¹G^{p+r})`, equivalent to the displayed +`(intersection + G^{p+1})/G^{p+1}` formula. -/ +abbrev SourcePage (r : ℕ) (p : ℤ) := + K.cycles r p ⧸ (K.G (p + 1)).comap (K.cycles r p).subtype + +/-- The actual target page `G^p/B_r`. -/ +abbrev TargetPage (r : ℕ) (p : ℤ) := + K.G p ⧸ (K.boundaries r p).comap (K.G p).subtype + +-- Explicit instances also resolve these groups inside dependent direct sums. +instance sourcePageAddCommGroup (r : ℕ) (p : ℤ) : AddCommGroup (K.SourcePage r p) := + inferInstanceAs (AddCommGroup + (K.cycles r p ⧸ (K.G (p + 1)).comap (K.cycles r p).subtype)) + +instance targetPageAddCommGroup (r : ℕ) (p : ℤ) : AddCommGroup (K.TargetPage r p) := + inferInstanceAs (AddCommGroup + (K.G p ⧸ (K.boundaries r p).comap (K.G p).subtype)) + +private def restrictedDrop (r : ℕ) (p : ℤ) : + K.cycles r p →ₗ[k] K.G (p + r) := + (K.f.comp (K.cycles r p).subtype).codRestrict (K.G (p + r)) + (fun x => x.property.2) + +private theorem drop_denominator (r : ℕ) (p : ℤ) : + (K.G (p + 1)).comap (K.cycles r p).subtype ≤ + ((K.boundaries r (p + r)).comap (K.G (p + r)).subtype).comap + (K.restrictedDrop r p) := by + intro x hx + change K.f (x : M) ∈ K.boundaries r (p + r) + apply Submodule.mem_sup.mpr + refine ⟨K.f (x : M), ⟨x.property.2, ?_⟩, 0, Submodule.zero_mem _, by simp⟩ + refine ⟨x, ?_, ?_⟩ + · simpa using hx + rfl + +/-- The page differential, formed by applying `f` to a representative. -/ +def drop (r : ℕ) (p : ℤ) : + K.SourcePage r p →ₗ[k] K.TargetPage r (p + r) := + Submodule.mapQ _ _ (K.restrictedDrop r p) (K.drop_denominator r p) + +/-- Representative formula for the page differential. -/ +@[simp] theorem drop_mk (r : ℕ) (p : ℤ) (x : K.cycles r p) : + K.drop r p (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (K.restrictedDrop r p x) := rfl + +/-- Cycle numerators decrease from page `r` to page `r+1`. -/ +theorem cycles_succ_le (r : ℕ) (p : ℤ) : + K.cycles (r + 1) p ≤ K.cycles r p := by + intro x hx + exact ⟨hx.1, K.antitone (by push_cast; omega) hx.2⟩ + +/-- Boundary numerators increase from page `r` to page `r+1`. -/ +theorem boundaries_le_succ (r : ℕ) (p : ℤ) : + K.boundaries r p ≤ K.boundaries (r + 1) p := by + apply sup_le + · apply le_sup_of_le_left + intro x hx + refine ⟨hx.1, ?_⟩ + rcases hx.2 with ⟨z, hz, rfl⟩ + refine ⟨z, K.antitone (by push_cast; omega) hz, rfl⟩ + · exact le_sup_of_le_right le_rfl + +/-- A representative in `Z_{r+1}` is killed by the `r`-page differential. -/ +theorem drop_mk_eq_zero_of_mem_cycles_succ (r : ℕ) (p : ℤ) + (x : K.cycles r p) (hx : (x : M) ∈ K.cycles (r + 1) p) : + K.drop r p (Submodule.Quotient.mk x) = 0 := by + rw [K.drop_mk] + rw [Submodule.Quotient.mk_eq_zero] + change K.f (x : M) ∈ K.boundaries r (p + r) + have hind : p + (r + 1 : ℕ) = p + (r : ℕ) + 1 := by + push_cast + omega + exact Submodule.mem_sup.mpr + ⟨0, Submodule.zero_mem _, K.f (x : M), (hind ▸ hx.2), by simp⟩ + +/-- Conversely, a representative killed by `d_r` can be changed by an +element of `G^{p+1}` to a representative in `Z_{r+1}`. -/ +theorem exists_cycles_succ_rep_of_drop_mk_eq_zero (r : ℕ) (p : ℤ) + (x : K.cycles r p) (hx : K.drop r p (Submodule.Quotient.mk x) = 0) : + ∃ z ∈ K.G (p + 1), (x : M) - z ∈ K.cycles (r + 1) p := by + rw [K.drop_mk, Submodule.Quotient.mk_eq_zero] at hx + rcases Submodule.mem_sup.mp hx with ⟨a, ha, e, he, hsum⟩ + rcases ha.2 with ⟨z, hz, rfl⟩ + change K.f z + e = K.f (x : M) at hsum + refine ⟨z, ?_, ?_⟩ + · simpa using hz + refine ⟨Submodule.sub_mem _ x.property.1 (K.next_le p (by simpa using hz)), ?_⟩ + have hind : p + (r + 1 : ℕ) = p + (r : ℕ) + 1 := by + push_cast + omega + rw [hind] + have hfe : K.f ((x : M) - z) = e := by + rw [map_sub, ← hsum] + simp + change K.f ((x : M) - z) ∈ K.G (p + (r : ℤ) + 1) + rw [hfe] + exact he + +/-- Every new boundary representative is a drop plus a lower-filtration term. -/ +theorem mem_boundaries_succ_rep (r : ℕ) (p : ℤ) + {y : M} (hy : y ∈ K.boundaries (r + 1) p) : + ∃ z ∈ K.G (p - r), ∃ e ∈ K.G (p + 1), y = K.f z + e := by + rcases Submodule.mem_sup.mp hy with ⟨y', hy', e, he, hsum⟩ + rcases hy' with ⟨hyp, z, hz, rfl⟩ + have hind : p - ((r + 1 : ℕ) : ℤ) + 1 = p - (r : ℤ) := by + push_cast + omega + exact ⟨z, hind ▸ hz, + e, he, hsum.symm⟩ + +/-- Surjectivity exhausts the target boundary numerators. -/ +theorem exists_mem_boundaries_of_surjective + (hG : ∀ z : M, ∃ s : ℤ, z ∈ K.G s) + (hf : Function.Surjective K.f) {p : ℤ} {y : M} (hy : y ∈ K.G p) : + ∃ r : ℕ, y ∈ K.boundaries r p := by + obtain ⟨z, rfl⟩ := hf y + obtain ⟨s, hs⟩ := hG z + obtain ⟨r, hr⟩ : ∃ r : ℕ, p - r + 1 ≤ s := by + refine ⟨Int.toNat (p - s + 1), ?_⟩ + omega + refine ⟨r, Submodule.mem_sup.mpr ?_⟩ + exact ⟨K.f z, ⟨hy, ⟨z, K.antitone hr hs, rfl⟩⟩, + 0, Submodule.zero_mem _, by simp⟩ + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermSuccessorNaturality.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermSuccessorNaturality.lean new file mode 100644 index 0000000000..42bd729775 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermSuccessorNaturality.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions + +/-! +# Naturality of the total successor maps + +The concrete successor maps on the source and target pages commute with the +page action. The proof is by direct-sum induction and quotient +representatives; no abstract successor-page interface is used. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +namespace PageOperator + +variable {K : FilteredTwoTerm k M} {d : ℤ} (P : K.PageOperator d) + +theorem sourceTotalSuccMap_naturality (r : ℕ) : + K.sourceTotalSuccMap r ∘ₗ P.sourceTotalMap (r + 1) = + P.sourceTotalMap r ∘ₗ K.sourceTotalSuccMap r := by + apply LinearMap.ext + intro x + induction x using DirectSum.induction_on with + | zero => simp + | of p x => + rw [show DirectSum.of (fun q : ℤ => K.SourcePage (r + 1) q) p x = + DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage (r + 1) q) p x from rfl] + rw [LinearMap.comp_apply, LinearMap.comp_apply] + simp only [sourceTotalSuccMap, DirectSum.lmap_lof] + rw [P.sourceTotalMap_lof] + change K.sourceTotalSuccMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage (r + 1) q) (p - d) + (P.sourceMap (r + 1) p x)) = + P.sourceTotalMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p + (K.sourceSuccMap r p x)) + rw [sourceTotalSuccMap, DirectSum.lmap_lof] + rw [P.sourceTotalMap_lof] + apply congrArg (fun z => + DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) (p - d) z) + refine Submodule.Quotient.induction_on + ((K.G (p + 1)).comap (K.cycles (r + 1) p).subtype) x ?_ + intro z + rw [K.sourceSuccMap_mk, P.sourceMap_mk] + simp [sourceSuccEquivKerDrop, sourceSuccKernelMap, sourceSuccMap] + apply (Submodule.Quotient.eq _).2 + change P.g (z : M) - P.g (z : M) ∈ K.G (p - d + 1) + simp + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + +theorem targetTotalSuccMap_naturality (r : ℕ) : + K.targetTotalSuccMap r ∘ₗ P.targetTotalMap r = + P.targetTotalMap (r + 1) ∘ₗ K.targetTotalSuccMap r := by + apply LinearMap.ext + intro x + induction x using DirectSum.induction_on with + | zero => simp + | of p x => + rw [show DirectSum.of (fun q : ℤ => K.TargetPage r q) p x = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) p x from rfl] + rw [LinearMap.comp_apply, LinearMap.comp_apply] + simp only [targetTotalSuccMap, DirectSum.lmap_lof] + rw [P.targetTotalMap_lof] + change K.targetTotalSuccMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p - d) + (P.targetMap r p x)) = + P.targetTotalMap (r + 1) + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage (r + 1) q) p + (K.targetSuccMap r p x)) + rw [targetTotalSuccMap, DirectSum.lmap_lof] + rw [P.targetTotalMap_lof] + apply congrArg (fun z => + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage (r + 1) q) (p - d) z) + refine Submodule.Quotient.induction_on + ((K.boundaries r p).comap (K.G p).subtype) x ?_ + intro z + rw [P.targetMap_mk] + change K.targetSuccMap r (p - d) + (Submodule.Quotient.mk (P.targetRestricted p z)) = + Submodule.Quotient.mk (P.targetRestricted p z) + rw [targetSuccMap, Submodule.mapQ_apply] + rfl + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + +end PageOperator + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalActions.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalActions.lean new file mode 100644 index 0000000000..4f63c6de25 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalActions.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages + +/-! +# Total direct-sum actions on filtered two-term pages + +This file packages the source and target page actions of a filtered operator +into maps on the total direct sums. The index shift is part of the map: an +operator of degree `d` sends the summand at `p` to the summand at `p - d`. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +namespace PageOperator + +variable {K} {d : ℤ} (P : K.PageOperator d) + +private theorem target_lof_transport (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.TargetPage r p) : + DirectSum.lof k ℤ (fun i : ℤ => K.TargetPage r i) p x = + DirectSum.lof k ℤ (fun i : ℤ => K.TargetPage r i) q (h ▸ x) := by + subst q + rfl + +private theorem targetPageCast_eq_cast (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.TargetPage r p) : + targetPageCast (K := K) r h x = h ▸ x := by + refine Submodule.Quotient.induction_on + ((K.boundaries r p).comap (K.G p).subtype) x ?_ + intro z + rw [targetPageCast_mk] + cases h + rfl + +/-- The source-page action on the total direct sum. -/ +def sourceTotalMap (r : ℕ) : K.SourceTotal r →ₗ[k] K.SourceTotal r := + DirectSum.toModule k ℤ (K.SourceTotal r) (fun p : ℤ => + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) (p - d)).comp + (P.sourceMap r p)) + +/-- The target-page action on the total direct sum. -/ +def targetTotalMap (r : ℕ) : K.TargetTotal r →ₗ[k] K.TargetTotal r := + DirectSum.toModule k ℤ (K.TargetTotal r) (fun p : ℤ => + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p - d)).comp + (P.targetMap r p)) + +@[simp] theorem sourceTotalMap_lof (r : ℕ) (p : ℤ) (x : K.SourcePage r p) : + P.sourceTotalMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p x) = + DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) (p - d) + (P.sourceMap r p x) := by + rw [sourceTotalMap, DirectSum.toModule_lof] + rfl + +@[simp] theorem targetTotalMap_lof (r : ℕ) (p : ℤ) (x : K.TargetPage r p) : + P.targetTotalMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) p x) = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p - d) + (P.targetMap r p x) := by + rw [targetTotalMap, DirectSum.toModule_lof] + rfl + +/-- The total action intertwines the total page differential. -/ +theorem totalDrop_intertwines (r : ℕ) : + K.totalDrop r ∘ₗ P.sourceTotalMap r = + P.targetTotalMap r ∘ₗ K.totalDrop r := by + apply LinearMap.ext + intro x + induction x using DirectSum.induction_on with + | zero => simp + | of p y => + rw [show DirectSum.of (fun q : ℤ => K.SourcePage r q) p y = + DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p y from rfl] + change K.totalDrop r (P.sourceTotalMap r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p y)) = + P.targetTotalMap r (K.totalDrop r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p y)) + rw [P.sourceTotalMap_lof, K.totalDrop_lof, K.totalDrop_lof, + P.targetTotalMap_lof] + have h : p + (r : ℤ) - d = p - d + (r : ℤ) := by omega + rw [target_lof_transport (K := K) r h] + congr 1 + symm + convert P.targetMap_drop r p y using 1 + exact (targetPageCast_eq_cast (K := K) r _ _).symm + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + + +private theorem source_lof_mk_eq_of_lower (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.cycles r p) (y : K.cycles r q) + (hxy : (x : M) - (y : M) ∈ K.G (p + 1)) : + DirectSum.lof k ℤ (fun i => K.SourcePage r i) p (Submodule.Quotient.mk x) = + DirectSum.lof k ℤ (fun i => K.SourcePage r i) q (Submodule.Quotient.mk y) := by + subst q + congr 1 + apply (Submodule.Quotient.eq _).2 + exact hxy + +private theorem target_lof_mk_eq_of_lower (r : ℕ) {p q : ℤ} (h : p = q) + (x : K.G p) (y : K.G q) + (hxy : (x : M) - (y : M) ∈ K.G (p + 1)) : + DirectSum.lof k ℤ (fun i => K.TargetPage r i) p (Submodule.Quotient.mk x) = + DirectSum.lof k ℤ (fun i => K.TargetPage r i) q (Submodule.Quotient.mk y) := by + subst q + congr 1 + apply (Submodule.Quotient.eq _).2 + exact Submodule.mem_sup.mpr ⟨0, Submodule.zero_mem _, + (x : M) - y, hxy, by simp⟩ + +/-- Lower-order commutators vanish in the total source symbol action. -/ +theorem sourceTotalMap_commute_of_commutator_lowers {e : ℤ} + (Q : K.PageOperator e) + (hlower : ∀ p z, z ∈ K.G p → + P.g (Q.g z) - Q.g (P.g z) ∈ K.G (p - d - e + 1)) (r : ℕ) : + Commute (P.sourceTotalMap r) (Q.sourceTotalMap r) := by + apply LinearMap.ext + intro z + induction z using DirectSum.induction_on with + | zero => simp + | of p z => + change P.sourceTotalMap r (Q.sourceTotalMap r + (DirectSum.lof k ℤ (fun i => K.SourcePage r i) p z)) = + Q.sourceTotalMap r (P.sourceTotalMap r + (DirectSum.lof k ℤ (fun i => K.SourcePage r i) p z)) + rw [Q.sourceTotalMap_lof, P.sourceTotalMap_lof, + P.sourceTotalMap_lof, Q.sourceTotalMap_lof] + induction z using Submodule.Quotient.induction_on with + | _ z => + rw [Q.sourceMap_mk, P.sourceMap_mk, P.sourceMap_mk, Q.sourceMap_mk] + apply source_lof_mk_eq_of_lower (K := K) r (by omega) + change P.g (Q.g (z : M)) - Q.g (P.g (z : M)) ∈ K.G (p - e - d + 1) + simpa only [sub_sub, add_comm] using hlower p (z : M) z.property.1 + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + +/-- Lower-order commutators vanish in the total target symbol action. -/ +theorem targetTotalMap_commute_of_commutator_lowers {e : ℤ} + (Q : K.PageOperator e) + (hlower : ∀ p z, z ∈ K.G p → + P.g (Q.g z) - Q.g (P.g z) ∈ K.G (p - d - e + 1)) (r : ℕ) : + Commute (P.targetTotalMap r) (Q.targetTotalMap r) := by + apply LinearMap.ext + intro z + induction z using DirectSum.induction_on with + | zero => simp + | of p z => + change P.targetTotalMap r (Q.targetTotalMap r + (DirectSum.lof k ℤ (fun i => K.TargetPage r i) p z)) = + Q.targetTotalMap r (P.targetTotalMap r + (DirectSum.lof k ℤ (fun i => K.TargetPage r i) p z)) + rw [Q.targetTotalMap_lof, P.targetTotalMap_lof, + P.targetTotalMap_lof, Q.targetTotalMap_lof] + induction z using Submodule.Quotient.induction_on with + | _ z => + rw [Q.targetMap_mk, P.targetMap_mk, P.targetMap_mk, Q.targetMap_mk] + apply target_lof_mk_eq_of_lower (K := K) r (by omega) + change P.g (Q.g (z : M)) - Q.g (P.g (z : M)) ∈ K.G (p - e - d + 1) + simpa only [sub_sub, add_comm] using hlower p (z : M) z.property + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + + +end PageOperator + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalPages.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalPages.lean new file mode 100644 index 0000000000..6ad82999d6 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FilteredTwoTermTotalPages.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageActions +import Mathlib.Algebra.DirectSum.Module + +/-! +# Total direct sums of the filtered two-term pages + +The page differential has target component indexed by `p + r`. This file +packages the component maps into one direct-sum map; no successor-page +interface is assumed here. +-/ + +namespace AlgebraicAnalysis.FilteredTwoTermPages + +universe u v + +variable {k : Type u} [Ring k] +variable {M : Type v} [AddCommGroup M] [Module k M] + +namespace FilteredTwoTerm + +variable (K : FilteredTwoTerm k M) + +/-- The direct sum of the source pages at page `r`. -/ +abbrev SourceTotal (r : ℕ) := + DirectSum ℤ (fun p : ℤ => K.SourcePage r p) + +/-- The direct sum of the target pages at page `r`. -/ +abbrev TargetTotal (r : ℕ) := + DirectSum ℤ (fun p : ℤ => K.TargetPage r p) + +/-- The total page differential, with the component at `p` landing at `p+r`. + +The reindexing is expressed by the corresponding direct-sum inclusion, so the +formula keeps the target shift visible at the definition site. +-/ +def totalDrop (r : ℕ) : K.SourceTotal r →ₗ[k] K.TargetTotal r := + DirectSum.toModule k ℤ (K.TargetTotal r) (fun p : ℤ => + (DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p + r)).comp + (K.drop r p)) + +/-- Component formula for the total differential. -/ +@[simp] theorem totalDrop_lof (r : ℕ) (p : ℤ) (x : K.SourcePage r p) : + K.totalDrop r (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p x) = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p + r) (K.drop r p x) := by + rw [totalDrop, DirectSum.toModule_lof] + rfl + +/-- Representative formula for a source-page quotient representative. + +This compatibility lemma intentionally retains the quotient representative on +the right-hand side, although the simplifier can reduce it further. -/ +@[simp, nolint simpNF] theorem totalDrop_lof_mk (r : ℕ) (p : ℤ) + (x : K.cycles r p) : + K.totalDrop r + (DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) p + (Submodule.Quotient.mk x)) = + DirectSum.lof k ℤ (fun q : ℤ => K.TargetPage r q) (p + r) + (K.drop r p (Submodule.Quotient.mk x)) := by + rw [K.totalDrop_lof, K.drop_mk] + +private theorem totalDrop_apply_component (r : ℕ) (p : ℤ) + (x : K.SourceTotal r) : + K.totalDrop r x (p + r) = K.drop r p (x p) := by + classical + induction x using DirectSum.induction_on with + | zero => simp + | of q y => + rw [show DirectSum.of (fun q : ℤ => K.SourcePage r q) q y = + DirectSum.lof k ℤ (fun q : ℤ => K.SourcePage r q) q y from rfl, + K.totalDrop_lof] + by_cases h : q = p + · subst q + simp + · have hshift : q + (r : ℤ) ≠ p + (r : ℤ) := by omega + change (DFinsupp.single (q + (r : ℤ)) (K.drop r q y)) (p + r) = + K.drop r p ((DFinsupp.single q y) p) + rw [DFinsupp.single_apply, DFinsupp.single_apply, dif_neg hshift, dif_neg h] + simp + | add x y hx hy => simpa using congrArg₂ (· + ·) hx hy + + +/-- The componentwise successor map on the total source page. -/ +noncomputable def sourceTotalSuccMap (r : ℕ) : + K.SourceTotal (r + 1) →ₗ[k] K.SourceTotal r := + DirectSum.lmap (fun p => + (LinearMap.ker (K.drop r p)).subtype.comp + (K.sourceSuccEquivKerDrop r p).toLinearMap) + +theorem totalSourceSuccMap_injective (r : ℕ) : + Function.Injective (K.sourceTotalSuccMap r) := by + apply (DirectSum.lmap_injective _).mpr + intro p + exact (Submodule.subtype_injective _).comp + (K.sourceSuccEquivKerDrop r p).injective + +theorem range_totalSourceSuccMap (r : ℕ) : + (K.sourceTotalSuccMap r).range = (K.totalDrop r).ker := by + rw [sourceTotalSuccMap, DirectSum.range_lmap] + ext x + change (∀ p ∈ Set.univ, x p ∈ LinearMap.range + ((LinearMap.ker (K.drop r p)).subtype.comp + (K.sourceSuccEquivKerDrop r p).toLinearMap)) ↔ K.totalDrop r x = 0 + constructor + · intro hx + apply DFinsupp.ext + intro q + have hq : q = (q - r) + r := by omega + rw [hq, K.totalDrop_apply_component] + obtain ⟨y, hy⟩ := hx (q - r) (Set.mem_univ _) + have hmem := (K.sourceSuccEquivKerDrop r (q - r) y).property + simpa only [LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, + Submodule.subtype_apply] using hy ▸ hmem + · intro hx p _ + have hzero : K.drop r p (x p) = 0 := by + rw [← K.totalDrop_apply_component, hx] + rfl + refine ⟨(K.sourceSuccEquivKerDrop r p).symm ⟨x p, hzero⟩, ?_⟩ + simp + +/-- The total successor source is the actual kernel of the total differential. -/ +noncomputable def sourceTotalSuccEquivKerDrop (r : ℕ) : + K.SourceTotal (r + 1) ≃ₗ[k] (K.totalDrop r).ker := + LinearEquiv.ofInjective (K.sourceTotalSuccMap r) + (K.totalSourceSuccMap_injective r) ≪≫ₗ + LinearEquiv.ofEq _ _ (K.range_totalSourceSuccMap r) + +private def targetReindex (r : ℕ) : + K.TargetTotal r ≃ₗ[k] DirectSum ℤ (fun p => K.TargetPage r (p + r)) := + DirectSum.lequivCongrLeft k + { toFun := fun p : ℤ => p - r + invFun := fun p => p + r + left_inv := by intro p; dsimp; omega + right_inv := by intro p; dsimp; omega } + +private theorem targetReindex_totalDrop (r : ℕ) (x : K.SourceTotal r) : + K.targetReindex r (K.totalDrop r x) = DirectSum.lmap (K.drop r) x := by + ext p + exact K.totalDrop_apply_component r p x + +/-- The componentwise quotient map on the total target page. -/ +def targetTotalSuccMap (r : ℕ) : + K.TargetTotal r →ₗ[k] K.TargetTotal (r + 1) := + DirectSum.lmap (K.targetSuccMap r) + +theorem ker_totalTargetSuccMap (r : ℕ) : + (K.targetTotalSuccMap r).ker = (K.totalDrop r).range := by + ext y + constructor + · intro hy + have hlocal : ∀ p, K.targetSuccMap r p (y p) = 0 := by + intro p + exact congrArg (fun z => z p) (LinearMap.mem_ker.mp hy) + have hmem : K.targetReindex r y ∈ (DirectSum.lmap (K.drop r)).range := by + rw [DirectSum.range_lmap] + change ∀ p ∈ Set.univ, y (p + r) ∈ (K.drop r p).range + intro p _ + rw [← K.ker_targetSuccMap_eq_range_drop] + exact hlocal (p + r) + obtain ⟨x, hx⟩ := hmem + refine ⟨x, (K.targetReindex r).injective ?_⟩ + rw [K.targetReindex_totalDrop] + exact hx + · rintro ⟨x, rfl⟩ + apply LinearMap.mem_ker.mpr + apply DFinsupp.ext + intro q + have hq : q = (q - r) + r := by omega + change K.targetSuccMap r q (K.totalDrop r x q) = 0 + rw [hq, K.totalDrop_apply_component] + apply LinearMap.mem_ker.mp + rw [K.ker_targetSuccMap_eq_range_drop] + exact ⟨x (q - r), rfl⟩ + +/-- The total successor target is the actual cokernel of the total differential. -/ +noncomputable def targetTotalSuccEquivCokerDrop (r : ℕ) : + K.TargetTotal (r + 1) ≃ₗ[k] (K.TargetTotal r ⧸ (K.totalDrop r).range) := + ((Submodule.quotEquivOfEq _ _ (K.ker_totalTargetSuccMap r).symm) ≪≫ₗ + (K.targetTotalSuccMap r).quotKerEquivOfSurjective + ((DirectSum.lmap_surjective _).mpr (K.targetSuccMap_surjective r))).symm + + +end FilteredTwoTerm + +end AlgebraicAnalysis.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/FreeSummandInduction.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FreeSummandInduction.lean new file mode 100644 index 0000000000..1f7afda4da --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/FreeSummandInduction.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.Unimodular + +/-! +# Finite iteration of unimodular splittings + +This file packages the unconditional finite iteration of normalized +functionals. It does not assert that such a sequence can be constructed +from rank or torsion hypotheses. +-/ + +namespace AlgebraicAnalysis.FreeSummandInduction + +variable {R : Type*} [Ring R] + +/-- The harmless zero-factor equivalence used at the start of an iteration. -/ +def emptyFactorEquiv (M : Type*) [AddCommGroup M] [Module R M] : + M ≃ₗ[R] M × (Fin 0 → R) := + { toFun := fun m ↦ (m, fun i ↦ Fin.elim0 i) + invFun := fun z ↦ z.1 + left_inv := by intro m; rfl + right_inv := by + intro z + apply Prod.ext + · rfl + · apply Subsingleton.elim + map_add' := by + intro m n + apply Prod.ext + · rfl + · apply Subsingleton.elim + map_smul' := by + intro r m + apply Prod.ext + · rfl + · apply Subsingleton.elim } + +theorem emptyFactorEquiv_apply (M : Type*) [AddCommGroup M] [Module R M] + (m : M) : emptyFactorEquiv (R := R) M m = (m, fun i ↦ Fin.elim0 i) := rfl + +/-- If every stage in a finite sequence has a specified unimodular element, +and the next module is identified with the preceding kernel, then all the +specified free rank-one factors split off simultaneously. -/ +theorem finite_unimodular_splitting + (M : ℕ → Type*) [∀ i, AddCommGroup (M i)] [∀ i, Module R (M i)] + (φ : ∀ i, M i →ₗ[R] R) (x : ∀ i, M i) + (hx : ∀ i, φ i (x i) = 1) + (hres : ∀ i, M (i + 1) ≃ₗ[R] LinearMap.ker (φ i)) : + ∀ n, Nonempty (M 0 ≃ₗ[R] M n × (Fin n → R)) := by + have hstep : ∀ i, M i ≃ₗ[R] M (i + 1) × R := by + intro i + exact (AlgebraicAnalysis.Unimodular.unimodularSplitEquiv (φ i) (x i) + (hx i)).trans ((hres i).symm.prodCongr (LinearEquiv.refl R R)) + intro n + induction n with + | zero => + exact ⟨emptyFactorEquiv (R := R) (M 0)⟩ + | succ n ih => + obtain ⟨e⟩ := ih + let factors : (R × (Fin n → R)) ≃ₗ[R] (Fin (n + 1) → R) := + (Fin.consLinearEquiv R (fun _ : Fin (n + 1) ↦ R)).trans + (LinearEquiv.refl R (Fin (n + 1) → R)) + let rearrange := + (LinearEquiv.prodAssoc R (M (n + 1)) R (Fin n → R)).trans + ((LinearEquiv.refl R (M (n + 1))).prodCongr factors) + exact ⟨e.trans (((hstep n).prodCongr + (LinearEquiv.refl R (Fin n → R))).trans rearrange)⟩ + + +end AlgebraicAnalysis.FreeSummandInduction diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/HyperplaneRestriction.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/HyperplaneRestriction.lean new file mode 100644 index 0000000000..ce8222626e --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/HyperplaneRestriction.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Finiteness.Nakayama +import Mathlib.RingTheory.Support + +/-! +# Algebraic hyperplane restriction + +For a finite module over a commutative ring, surjectivity of multiplication +by an element forces the module support to avoid the corresponding principal +hypersurface. The proof is the determinant trick and is independent of any +filtered or differential-operator application. +-/ + +namespace AlgebraicAnalysis.HyperplaneRestriction + +open scoped Pointwise + +variable {R M : Type*} [CommRing R] [AddCommGroup M] [Module R M] + +/-- Degree-zero restriction to the principal hypersurface defined by `x`. -/ +abbrev Restriction (x : R) : Type _ := + M ⧸ (Ideal.span {x} • (⊤ : Submodule R M)) + +/-- Restriction vanishes exactly when multiplication by `x` is surjective. -/ +theorem restriction_subsingleton_iff_smul_surjective {x : R} : + Subsingleton (Restriction (M := M) x) ↔ + Function.Surjective fun m : M ↦ x • m := by + have hquotient : + Subsingleton (Restriction (M := M) x) ↔ + Ideal.span {x} • (⊤ : Submodule R M) = ⊤ := by + constructor + · intro h + apply Submodule.unique_quotient_iff_eq_top.mp + exact ⟨{ + default := 0 + uniq := fun y ↦ h.elim y 0 }⟩ + · intro h + obtain ⟨hunique⟩ := Submodule.unique_quotient_iff_eq_top.mpr h + exact @Unique.instSubsingleton _ hunique + rw [hquotient] + constructor + · intro htop m + have hm : m ∈ x • (⊤ : Submodule R M) := by + rw [← Submodule.ideal_span_singleton_smul, htop] + exact Submodule.mem_top + rw [← Submodule.singleton_set_smul] at hm + obtain ⟨n, hn, hmn⟩ := + (Submodule.mem_singleton_set_smul (⊤ : Submodule R M) x m).mp hm + exact ⟨n, hmn.symm⟩ + · intro hx + apply top_unique + intro m hm + obtain ⟨n, rfl⟩ := hx m + exact Submodule.smul_mem_smul + (Ideal.subset_span (by simp)) + (Submodule.mem_top : n ∈ (⊤ : Submodule R M)) + +theorem restriction_subsingleton_of_smul_surjective {x : R} + (hx : Function.Surjective fun m : M ↦ x • m) : + Subsingleton (Restriction (M := M) x) := + restriction_subsingleton_iff_smul_surjective.mpr hx + +/-- Determinant-trick certificate for a surjective scalar action. -/ +theorem exists_annihilator_sub_one_mem_span_of_smul_surjective + [Module.Finite R M] {x : R} + (hx : Function.Surjective fun m : M ↦ x • m) : + ∃ r : R, r - 1 ∈ Ideal.span {x} ∧ ∀ m : M, r • m = 0 := by + obtain ⟨r, hr, hrann⟩ := + Submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul + (Ideal.span {x}) (⊤ : Submodule R M) Module.Finite.fg_top (by + intro m hm + obtain ⟨n, rfl⟩ := hx m + exact Submodule.smul_mem_smul + (Ideal.subset_span (by simp)) + (Submodule.mem_top : n ∈ (⊤ : Submodule R M))) + exact ⟨r, hr, fun m ↦ hrann m Submodule.mem_top⟩ + +/-- A support prime containing `x` is impossible when `x` acts surjectively. -/ +theorem not_mem_support_of_smul_surjective_of_mem + [Module.Finite R M] {x : R} + (hx : Function.Surjective fun m : M ↦ x • m) + (p : PrimeSpectrum R) (hxp : x ∈ p.asIdeal) : + p ∉ Module.support R M := by + intro hp + obtain ⟨r, hrspan, hrann⟩ := + exists_annihilator_sub_one_mem_span_of_smul_surjective hx + have hrp : r ∈ p.asIdeal := + Module.annihilator_le_of_mem_support hp (Module.mem_annihilator.mpr hrann) + have hsubp : r - 1 ∈ p.asIdeal := + (Ideal.span_le.mpr (by simpa using hxp)) hrspan + have hone : (1 : R) ∈ p.asIdeal := by + have := p.asIdeal.sub_mem hrp hsubp + simpa using this + exact p.2.ne_top ((Ideal.eq_top_iff_one p.asIdeal).mpr hone) + +/-- The support of a finite module with surjective `x`-action avoids `V(x)`. -/ +theorem support_disjoint_zeroLocus_of_smul_surjective + [Module.Finite R M] {x : R} + (hx : Function.Surjective fun m : M ↦ x • m) : + Disjoint (Module.support R M) (PrimeSpectrum.zeroLocus ({x} : Set R)) := by + rw [Set.disjoint_left] + intro p hp hpx + rw [PrimeSpectrum.mem_zeroLocus] at hpx + exact not_mem_support_of_smul_surjective_of_mem hx p (hpx (by simp)) hp + +/-- Restriction-vanishing form of support exclusion. -/ +theorem support_disjoint_zeroLocus_of_restriction_subsingleton + [Module.Finite R M] {x : R} + (hx : Subsingleton (Restriction (M := M) x)) : + Disjoint (Module.support R M) (PrimeSpectrum.zeroLocus ({x} : Set R)) := + support_disjoint_zeroLocus_of_smul_surjective + (restriction_subsingleton_iff_smul_surjective.mp hx) + +/-- Complement-inclusion form of support exclusion. -/ +theorem support_subset_compl_zeroLocus_of_smul_surjective + [Module.Finite R M] {x : R} + (hx : Function.Surjective fun m : M ↦ x • m) : + Module.support R M ⊆ (PrimeSpectrum.zeroLocus ({x} : Set R))ᶜ := by + intro p hp hpx + exact Set.disjoint_left.mp + (support_disjoint_zeroLocus_of_smul_surjective hx) hp hpx + + +end AlgebraicAnalysis.HyperplaneRestriction diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedKernelCokernelEquivalences.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedKernelCokernelEquivalences.lean new file mode 100644 index 0000000000..25016b861f --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedKernelCokernelEquivalences.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Module.LocalizedModule.Submodule + +/-! +# Kernel and cokernel equivalences for module localization + +The actual localization functor preserves the two elementary constructions +needed by the successor pages. The equivalences below are obtained from the +canonical submodule and quotient localization equivalences in Mathlib. +-/ + +namespace AlgebraicAnalysis.LocalizedKernelCokernelEquivalences + +universe u v w + +variable {R : Type u} [CommRing R] +variable {U : Type v} {V : Type w} +variable [AddCommGroup U] [AddCommGroup V] +variable [Module R U] [Module R V] + +noncomputable section + +variable (S : Submonoid R) (f : U →ₗ[R] V) + +/-- The localization of an `R`-linear map, regarded as a map over the +localized ring. -/ +noncomputable def localizedMap : LocalizedModule S U →ₗ[Localization S] + LocalizedModule S V := + (LocalizedModule.map S f).extendScalarsOfIsLocalization S (Localization S) + +@[simp] theorem localizedMap_apply (x : LocalizedModule S U) : + localizedMap S f x = LocalizedModule.map S f x := + rfl + +/-- Localization carries an actual linear equivalence to an equivalence over +the localized ring. -/ +noncomputable def localizedEquiv (e : U ≃ₗ[R] V) : + LocalizedModule S U ≃ₗ[Localization S] LocalizedModule S V := + LinearEquiv.ofBijective (localizedMap S e.toLinearMap) (by + constructor + · simpa [localizedMap] using + (LocalizedModule.map_injective S e.toLinearMap e.injective) + · simpa [localizedMap] using + (LocalizedModule.map_surjective S e.toLinearMap e.surjective)) + +/-- Localization commutes with kernels. -/ +noncomputable def localizedKernelEquiv : + LocalizedModule S (LinearMap.ker f) ≃ₗ[Localization S] + LinearMap.ker (localizedMap S f) := by + let e₁ : (LinearMap.ker f).localized' (Localization S) S + (LocalizedModule.mkLinearMap S U) ≃ₗ[Localization S] + LocalizedModule S (LinearMap.ker f) := + Submodule.localizedEquiv S (LinearMap.ker f) + let e₂ : (LinearMap.ker f).localized' (Localization S) S + (LocalizedModule.mkLinearMap S U) ≃ₗ[Localization S] + LinearMap.ker (localizedMap S f) := + LinearEquiv.ofEq _ _ + (LinearMap.localized'_ker_eq_ker_localizedMap (Localization S) S + (LocalizedModule.mkLinearMap S U) (LocalizedModule.mkLinearMap S V) f) + exact e₁.symm.trans e₂ + +/-- Localization commutes with cokernels. -/ +noncomputable def localizedCokernelEquiv : + LocalizedModule S (V ⧸ LinearMap.range f) ≃ₗ[Localization S] + LocalizedModule S V ⧸ LinearMap.range (localizedMap S f) := by + let h : Submodule.localized S (LinearMap.range f) = + LinearMap.range (localizedMap S f) := by + have hm : + IsLocalizedModule.map S (LocalizedModule.mkLinearMap S U) + (LocalizedModule.mkLinearMap S V) f = LocalizedModule.map S f := by + ext x + induction x using LocalizedModule.induction_on with + | _ x s => + rw [IsLocalizedModule.map_LocalizedModules] + exact (LocalizedModule.map_mk S f x s).symm + simpa [localizedMap, hm] using + (LinearMap.localized'_range_eq_range_localizedMap + (Localization S) S (LocalizedModule.mkLinearMap S U) + (LocalizedModule.mkLinearMap S V) f) + let e₁ : (LocalizedModule S V ⧸ + Submodule.localized S (LinearMap.range f)) ≃ₗ[Localization S] + LocalizedModule S (V ⧸ LinearMap.range f) := + localizedQuotientEquiv S (LinearMap.range f) + let e : LocalizedModule S V ≃ₗ[Localization S] LocalizedModule S V := + LinearEquiv.refl _ _ + exact e₁.symm.trans + (Submodule.Quotient.equiv _ _ e (by simpa [e] using h)) + +end +end AlgebraicAnalysis.LocalizedKernelCokernelEquivalences diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedMinimalSupportAvoidance.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedMinimalSupportAvoidance.lean new file mode 100644 index 0000000000..7aa17bf749 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/LocalizedMinimalSupportAvoidance.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Module.LocalizedModule.Basic +import Mathlib.RingTheory.Ideal.MinimalPrime.Localization +import Mathlib.RingTheory.Support + +/-! +# Transport of minimal-prime support avoidance through localization + +For a finite module, localization commutes with its annihilator. The reverse +inclusion uses a finite generating set to clear all denominators at once. +Minimal-prime avoidance then follows from the ordinary minimal-prime +correspondence for a localization. +-/ + +namespace AlgebraicAnalysis.LocalizedMinimalSupportAvoidance + +noncomputable section + +variable {C E : Type*} [CommRing C] [AddCommGroup E] [Module C E] + +/-- The annihilator of a finite module commutes with localization. -/ +theorem annihilator_localizedModule + [Module.Finite C E] (S : Submonoid C) : + Module.annihilator (Localization S) (LocalizedModule S E) = + Ideal.map (algebraMap C (Localization S)) (Module.annihilator C E) := by + apply le_antisymm + · intro z hz + obtain ⟨⟨c, d⟩, rfl⟩ := IsLocalization.mk'_surjective S z + obtain ⟨gens, hgens⟩ := (inferInstance : Module.Finite C E) + have hclear : ∀ e ∈ gens, ∃ u : S, u • (c • e) = 0 := by + intro e he + have hzero : + IsLocalization.mk' (Localization S) c d • LocalizedModule.mk e 1 = 0 := + Module.mem_annihilator.mp hz _ + rw [IsLocalizedModule.mk_eq_mk'] at hzero + rw [IsLocalizedModule.mk'_smul_mk', IsLocalizedModule.mk'_eq_zero'] at hzero + exact hzero + choose u hu using hclear + let t : S := gens.attach.prod fun e => u e e.property + have htc : (t : C) * c ∈ Module.annihilator C E := by + rw [Module.mem_annihilator] + intro e + refine Submodule.span_induction ?_ (smul_zero _) ?_ ?_ + (show e ∈ Submodule.span C (gens : Set E) by rw [hgens]; trivial) + · intro e he + obtain ⟨v, hv⟩ := Finset.dvd_prod_of_mem + (fun a : gens => u a a.property) (Finset.mem_attach gens ⟨e, he⟩) + have hue : (((u e he : S) : C) * c) • e = 0 := by + simpa only [mul_smul, Submonoid.smul_def] using hu e he + change (((t : S) : C) * c) • e = 0 + rw [show t = gens.attach.prod (fun a => u a a.property) by rfl, hv, + Submonoid.coe_mul, mul_comm ((u e he : S) : C) (v : C), + mul_assoc, mul_smul, hue, smul_zero] + · intro e₁ e₂ _ _ he₁ he₂ + rw [smul_add, he₁, he₂, zero_add] + · intro a e _ he + rw [smul_comm, he, smul_zero] + rw [IsLocalization.mk'_mem_map_algebraMap_iff] + exact ⟨t, t.property, htc⟩ + · rw [Ideal.map_le_iff_le_comap] + intro c hc + rw [Ideal.mem_comap, Module.mem_annihilator] + intro y + induction y using LocalizedModule.induction_on with + | _ e d => + rw [IsLocalizedModule.mk_eq_mk'] + rw [← IsLocalization.mk'_one (M := S), IsLocalizedModule.mk'_smul_mk', + Module.mem_annihilator.mp hc e] + simp + +/-- Minimal-prime avoidance survives localization. -/ +@[nolint unusedArguments] +theorem localized_minimalPrime_avoids + [IsNoetherianRing C] [Module.Finite C E] + (S : Submonoid C) (x : C) + (havoid : ∀ p ∈ (Module.annihilator C E).minimalPrimes, x ∉ p) : + ∀ Q ∈ (Module.annihilator (Localization S) + (LocalizedModule S E)).minimalPrimes, + algebraMap C (Localization S) x ∉ Q := by + intro Q hQ + have hQmap : Q ∈ + (Ideal.map (algebraMap C (Localization S)) + (Module.annihilator C E)).minimalPrimes := by + rw [← annihilator_localizedModule S] + exact hQ + have hQunder : + Ideal.under C Q ∈ (Module.annihilator C E).minimalPrimes := by + rw [IsLocalization.minimalPrimes_map S + (Localization S) (Module.annihilator C E)] at hQmap + exact hQmap + intro hxQ + exact havoid (Ideal.under C Q) hQunder hxQ + +end + +end AlgebraicAnalysis.LocalizedMinimalSupportAvoidance diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalPrimeFiniteLengthLocalization.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalPrimeFiniteLengthLocalization.lean new file mode 100644 index 0000000000..957c9baa35 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalPrimeFiniteLengthLocalization.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.FiniteLength +import Mathlib.Algebra.Module.Torsion.Basic +import Mathlib.RingTheory.Finiteness.Ideal +import Mathlib.RingTheory.Ideal.MinimalPrime.Localization +import Mathlib.RingTheory.Localization.Finiteness +import Mathlib.RingTheory.Noetherian.Basic +import Mathlib.RingTheory.Support + +/-! +# Finite length at a minimal prime of a finite module + +This file isolates the commutative-algebra localization statement used later: +if `P` is minimal over the annihilator of a finite module, then localization at +`P` is nonzero and has finite length. +-/ + +namespace AlgebraicAnalysis.MinimalPrimeFiniteLengthLocalization + +noncomputable section + +open scoped Pointwise + +variable {A M : Type*} [CommRing A] [AddCommGroup M] [Module A M] + +/-- A finite module over a Noetherian local ring has finite length as soon as +a power of the maximal ideal annihilates it. -/ +theorem finiteLength_of_maximalIdeal_pow_smul_eq_bot + [IsLocalRing A] [IsNoetherianRing A] [Module.Finite A M] + {n : ℕ} + (hpow : (IsLocalRing.maximalIdeal A ^ n) • (⊤ : Submodule A M) = ⊥) : + IsFiniteLength A M := by + induction n generalizing M with + | zero => + have htop : (⊤ : Submodule A M) = ⊥ := by simpa using hpow + have : Subsingleton M := + ⟨fun x y ↦ by + have hx : x = 0 := by + have : x ∈ (⊥ : Submodule A M) := by rw [← htop]; trivial + simpa using this + have hy : y = 0 := by + have : y ∈ (⊥ : Submodule A M) := by rw [← htop]; trivial + simpa using this + exact hx.trans hy.symm⟩ + exact .of_subsingleton + | succ n ih => + let m : Ideal A := IsLocalRing.maximalIdeal A + let N : Submodule A M := m • (⊤ : Submodule A M) + have hNpow : (m ^ n) • (⊤ : Submodule A N) = ⊥ := by + rw [Submodule.eq_bot_iff] + intro x hx + apply Subtype.ext + change (x : M) = 0 + have hx' : (x : M) ∈ (m ^ n) • N := + (Submodule.mem_smul_top_iff (I := m ^ n) N x).mp hx + have hxbot : (x : M) ∈ (⊥ : Submodule A M) := by + rw [← hpow, show IsLocalRing.maximalIdeal A = m from rfl, + pow_succ, mul_smul] + exact hx' + simpa using hxbot + have hNfinite : IsFiniteLength A N := ih hNpow + let hQtor : Module.IsTorsionBySet A (M ⧸ N) m := by + simpa only [N] using Module.isTorsionBySet_quotient_ideal_smul M m + let : m.IsMaximal := by dsimp [m]; infer_instance + let : Module (A ⧸ m) (M ⧸ N) := hQtor.module + let : IsScalarTower A (A ⧸ m) (M ⧸ N) := hQtor.isScalarTower + let : Field (A ⧸ m) := Ideal.Quotient.field m + have : Module.Finite A (M ⧸ N) := Module.Finite.quotient A N + have : Module.Finite (A ⧸ m) (M ⧸ N) := + Module.Finite.of_restrictScalars_finite A (A ⧸ m) (M ⧸ N) + have hQartinianQuot : IsArtinian (A ⧸ m) (M ⧸ N) := inferInstance + have hQartinian : IsArtinian A (M ⧸ N) := by + let e : Submodule (A ⧸ m) (M ⧸ N) ≃o Submodule A (M ⧸ N) := + { Submodule.restrictScalarsEmbedding A (A ⧸ m) (M ⧸ N) with + invFun := fun p ↦ + { carrier := p + add_mem' := p.add_mem + zero_mem' := p.zero_mem + smul_mem' := by + rintro ⟨a⟩ x hx + exact p.smul_mem a hx } + left_inv := by intro p; ext; rfl + right_inv := by intro p; ext; rfl } + exact ⟨e.symm.toOrderEmbedding.wellFounded hQartinianQuot.wf⟩ + rw [isFiniteLength_iff_isNoetherian_isArtinian] + exact ⟨inferInstance, + (isArtinian_iff_submodule_quotient N).mpr + ⟨(isFiniteLength_iff_isNoetherian_isArtinian.mp hNfinite).2, hQartinian⟩⟩ + +variable {R G : Type*} [CommRing R] + [AddCommGroup G] [Module R G] + +/-- Localization preserves finite generation for the canonical localized +module. -/ +theorem localizedModule_finite [Module.Finite R G] + (P : Ideal R) [P.IsPrime] : + Module.Finite (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := by + exact Module.Finite.of_isLocalizedModule P.primeCompl + (LocalizedModule.mkLinearMap P.primeCompl G) + +/-- A minimal prime over the annihilator belongs to the support, so the +corresponding localization is nonzero. -/ +theorem localizedModule_nontrivial + [Module.Finite R G] (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + Nontrivial (LocalizedModule P.primeCompl G) := by + let p : PrimeSpectrum R := ⟨P, inferInstance⟩ + have hp : p ∈ Module.support R G := + Module.mem_support_iff_of_finite.mpr hP.1.2 + simpa [p] using (Module.mem_support_iff.mp hp) + +/-- At a minimal prime over the module annihilator, the localized maximal +ideal lies in the radical of the mapped annihilator. -/ +theorem maximalIdeal_le_radical_map_annihilator + (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + IsLocalRing.maximalIdeal (Localization P.primeCompl) ≤ + (Ideal.map (algebraMap R (Localization P.primeCompl)) + (Module.annihilator R G)).radical := by + rw [← Localization.AtPrime.map_eq_maximalIdeal] + rw [Ideal.radical_eq_sInf, le_sInf_iff] + rintro q ⟨hmap, hqprime⟩ + obtain ⟨hcomapPrime, hcomapLe⟩ := + ((IsLocalization.AtPrime.orderIsoOfPrime + (Localization P.primeCompl) P) ⟨q, hqprime⟩).2 + rw [Ideal.map_le_iff_le_comap] at hmap ⊢ + exact hP.2 ⟨hcomapPrime, hmap⟩ hcomapLe + +/-- Mapping the original annihilator into the localization gives elements +that annihilate every localized fraction. -/ +theorem map_annihilator_le_localized_annihilator + (P : Ideal R) [P.IsPrime] : + Ideal.map (algebraMap R (Localization P.primeCompl)) + (Module.annihilator R G) ≤ + Module.annihilator (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := by + rw [Ideal.map_le_iff_le_comap] + intro r hr + rw [Ideal.mem_comap, Module.mem_annihilator] + intro z + induction z using LocalizedModule.induction_on with + | _ g s => + change Localization.mk r (1 : P.primeCompl) • + LocalizedModule.mk g s = 0 + rw [LocalizedModule.mk_smul_mk] + have hrg : r • g = 0 := Module.mem_annihilator.mp hr g + rw [hrg, LocalizedModule.zero_mk] + +/-- A power of the localized maximal ideal annihilates the localized finite +module. -/ +@[nolint unusedArguments] +theorem exists_maximalIdeal_pow_le_localized_annihilator + [IsNoetherianRing R] [Module.Finite R G] + (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + ∃ n : ℕ, IsLocalRing.maximalIdeal (Localization P.primeCompl) ^ n ≤ + Module.annihilator (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := by + let A := Localization P.primeCompl + have : IsNoetherianRing A := + IsLocalization.isNoetherianRing P.primeCompl A inferInstance + have hrad : IsLocalRing.maximalIdeal A ≤ + (Module.annihilator A (LocalizedModule P.primeCompl G)).radical := + (maximalIdeal_le_radical_map_annihilator P hP).trans + (Ideal.radical_mono (map_annihilator_le_localized_annihilator P)) + exact Ideal.exists_pow_le_of_le_radical_of_fg hrad + (Module.Finite.iff_fg.mp (inferInstance : + Module.Finite A (IsLocalRing.maximalIdeal A))) + +/-- The localized module at a minimal prime over its annihilator has finite +length over the local ring. -/ +theorem localizedModule_isFiniteLength + [IsNoetherianRing R] [Module.Finite R G] + (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + IsFiniteLength (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := by + let A := Localization P.primeCompl + have : IsNoetherianRing A := + IsLocalization.isNoetherianRing P.primeCompl A inferInstance + have : Module.Finite A (LocalizedModule P.primeCompl G) := + localizedModule_finite P + obtain ⟨n, hn⟩ := exists_maximalIdeal_pow_le_localized_annihilator P hP + have hann : Module.annihilator A (LocalizedModule P.primeCompl G) • + (⊤ : Submodule A (LocalizedModule P.primeCompl G)) = ⊥ := by + rw [← Submodule.annihilator_top] + exact Submodule.annihilator_smul + (⊤ : Submodule A (LocalizedModule P.primeCompl G)) + apply finiteLength_of_maximalIdeal_pow_smul_eq_bot (n := n) + apply le_antisymm + · calc + IsLocalRing.maximalIdeal A ^ n • + (⊤ : Submodule A (LocalizedModule P.primeCompl G)) + ≤ Module.annihilator A (LocalizedModule P.primeCompl G) • + (⊤ : Submodule A (LocalizedModule P.primeCompl G)) := + Submodule.smul_mono hn le_rfl + _ = ⊥ := hann + · exact bot_le + +/-- The load-bearing package: localization at a minimal prime over the +annihilator is simultaneously nonzero and of finite length. -/ +theorem localizedModule_nontrivial_and_isFiniteLength + [IsNoetherianRing R] [Module.Finite R G] + (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + Nontrivial (LocalizedModule P.primeCompl G) ∧ + IsFiniteLength (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := + ⟨localizedModule_nontrivial P hP, localizedModule_isFiniteLength P hP⟩ + + +end + +end AlgebraicAnalysis.MinimalPrimeFiniteLengthLocalization diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportExistence.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportExistence.lean new file mode 100644 index 0000000000..d8ae985528 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportExistence.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Ideal.MinimalPrime.Basic +import Mathlib.RingTheory.Support + +/-! +# Existence of a minimal support prime + +A nontrivial finite module over a commutative Noetherian ring has a prime in +its support which is minimal among the support primes. +-/ + +namespace AlgebraicAnalysis.MinimalSupportExistence + +noncomputable section + +variable {R U : Type*} [CommRing R] [AddCommGroup U] [Module R U] + +@[nolint unusedArguments] +theorem exists_minimal_support_prime + [IsNoetherianRing R] [Module.Finite R U] [Nontrivial U] : + ∃ q : PrimeSpectrum R, + q ∈ Module.support R U ∧ + ∀ p ∈ Module.support R U, p.asIdeal ≤ q.asIdeal → + q.asIdeal ≤ p.asIdeal := by + have hann : Module.annihilator R U ≠ ⊤ := by + intro h + have hs : Subsingleton U := Module.annihilator_eq_top_iff.mp h + exact not_subsingleton_iff_nontrivial.mpr inferInstance hs + obtain ⟨q, hq⟩ := + (Module.annihilator R U).nonempty_minimalPrimes hann + let Q : PrimeSpectrum R := ⟨q, hq.1.1⟩ + refine ⟨Q, Module.mem_support_iff_of_finite.mpr hq.1.2, ?_⟩ + intro p hp hpq + exact hq.2 + ⟨p.isPrime, Module.mem_support_iff_of_finite.mp hp⟩ hpq + + +end +end AlgebraicAnalysis.MinimalSupportExistence diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportKernelCokernelLengths.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportKernelCokernelLengths.lean new file mode 100644 index 0000000000..249758075b --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MinimalSupportKernelCokernelLengths.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization +import Mathlib.RingTheory.Support + +/-! +# Finite length of a localized kernel and cokernel + +This is the small commutative-algebra adapter needed when the finite module is +over a larger coefficient algebra. Finiteness over the base is supplied +explicitly; no restriction-of-scalars finiteness of the ambient module is +used. +-/ + +namespace AlgebraicAnalysis + +open scoped Pointwise + +noncomputable section + +private theorem localized_isFiniteLength_of_minimal_support + {R N : Type*} [CommRing R] [AddCommGroup N] [Module R N] + [IsNoetherianRing R] [Module.Finite R N] + (q : PrimeSpectrum R) + (hqmem : q ∈ Module.support R N) + (hq : ∀ p ∈ Module.support R N, p.asIdeal ≤ q.asIdeal → + q.asIdeal ≤ p.asIdeal) : + IsFiniteLength (Localization q.asIdeal.primeCompl) + (LocalizedModule q.asIdeal.primeCompl N) := by + have hqmem' : q ∈ Module.support R N := hqmem + have hqmem := hqmem' + have hmin : q.asIdeal ∈ (Module.annihilator R N).minimalPrimes := by + obtain ⟨p, hp, hpq⟩ := + Ideal.exists_minimalPrimes_le + (Module.mem_support_iff_of_finite.mp hqmem) + have hpprime : p.IsPrime := hp.1.1 + let p' : PrimeSpectrum R := ⟨p, hpprime⟩ + have hp'supp : p' ∈ Module.support R N := + Module.mem_support_iff_of_finite.mpr hp.1.2 + have hqp : q.asIdeal ≤ p := hq p' hp'supp hpq + have heq : p = q.asIdeal := le_antisymm hpq hqp + simpa [heq] using hp + exact MinimalPrimeFiniteLengthLocalization.localizedModule_isFiniteLength + q.asIdeal hmin + +theorem localized_kernel_and_cokernel_isFiniteLength + {R C E : Type*} [CommRing R] [CommRing C] [Algebra R C] + [AddCommGroup E] [Module C E] [Module R E] [IsScalarTower R C E] + [IsNoetherianRing R] [IsNoetherianRing C] [Module.Finite C E] + (f : Module.End C E) + [Module.Finite R (LinearMap.ker (f.restrictScalars R))] + [Module.Finite R (E ⧸ LinearMap.range (f.restrictScalars R))] + (q : PrimeSpectrum R) + (hqmem : q ∈ Module.support R (E ⧸ LinearMap.range (f.restrictScalars R))) + (hq : ∀ p ∈ Module.support R (E ⧸ LinearMap.range (f.restrictScalars R)), + p.asIdeal ≤ q.asIdeal → q.asIdeal ≤ p.asIdeal) : + IsFiniteLength (Localization q.asIdeal.primeCompl) + (LocalizedModule q.asIdeal.primeCompl + (E ⧸ LinearMap.range (f.restrictScalars R))) ∧ + IsFiniteLength (Localization q.asIdeal.primeCompl) + (LocalizedModule q.asIdeal.primeCompl + (LinearMap.ker (f.restrictScalars R))) := by + have hc := localized_isFiniteLength_of_minimal_support q hqmem hq + have hksub := + endomorphism_kernel_support_subset_cokernel_support_over_base + (R := R) (C := C) (E := E) f + by_cases hk : q ∈ Module.support R (LinearMap.ker (f.restrictScalars R)) + · have hqk : ∀ p ∈ Module.support R (LinearMap.ker (f.restrictScalars R)), + p.asIdeal ≤ q.asIdeal → q.asIdeal ≤ p.asIdeal := by + intro p hp hpq + exact hq p (hksub hp) hpq + exact ⟨hc, localized_isFiniteLength_of_minimal_support q hk hqk⟩ + · have hsub : Subsingleton (LocalizedModule q.asIdeal.primeCompl + (LinearMap.ker (f.restrictScalars R))) := + not_nontrivial_iff_subsingleton.mp (by + intro h + exact hk (Module.mem_support_iff.mpr h)) + let := hsub + exact ⟨hc, IsFiniteLength.of_subsingleton⟩ + + +end +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/MonicAnnihilatorFinite.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MonicAnnihilatorFinite.lean new file mode 100644 index 0000000000..ff7f5b8bb2 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/MonicAnnihilatorFinite.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.AdjoinRoot +import Mathlib.Algebra.Module.Torsion.Basic +import Mathlib.RingTheory.Finiteness.Basic +import Mathlib.RingTheory.Polynomial.Basic + +/-! +# Finiteness from a monic annihilator + +A finite polynomial-ring module annihilated by a monic polynomial is finite +over the coefficient ring. This is the algebraic finiteness step for the +normal covariable; no characteristic-support assertion is assumed. +-/ + +namespace AlgebraicAnalysis.MonicAnnihilatorFinite + +open Polynomial + +theorem finite_of_monic_annihilator {R E : Type*} [CommRing R] + [AddCommGroup E] [Module R E] [Module R[X] E] + [IsScalarTower R R[X] E] [Module.Finite R[X] E] + (g : R[X]) (hg : g.Monic) (hkill : ∀ z : E, g • z = 0) : + Module.Finite R E := by + have ht : Module.IsTorsionBySet R[X] E (Ideal.span {g}) := by + rw [Module.isTorsionBySet_span_singleton_iff] + exact hkill + let := ht.module + let : IsScalarTower R[X] (R[X] ⧸ Ideal.span {g}) E := + ht.isScalarTower + let : IsScalarTower R (R[X] ⧸ Ideal.span {g}) E := + ht.isScalarTower + let : Module.Finite (R[X] ⧸ Ideal.span {g}) E := + Module.Finite.of_restrictScalars_finite R[X] (R[X] ⧸ Ideal.span {g}) E + let := hg.finite_quotient + exact Module.Finite.trans (R[X] ⧸ Ideal.span {g}) E + +/-- A finite module killed by the polynomial variable is finite over the +coefficient ring. -/ +theorem finite_of_variable_annihilates {R E : Type*} [CommRing R] + [AddCommGroup E] [Module R E] [Module R[X] E] + [IsScalarTower R R[X] E] [Module.Finite R[X] E] + (hkill : ∀ z : E, (X : R[X]) • z = 0) : Module.Finite R E := + finite_of_monic_annihilator X monic_X hkill + +/-- Both terms of the principal Koszul homology are finite over the +coefficient ring, although the ambient module need not be. -/ +theorem finite_kernel_and_cokernel_variable {R E : Type*} [CommRing R] + [IsNoetherianRing R] [AddCommGroup E] [Module R E] [Module R[X] E] + [IsScalarTower R R[X] E] [Module.Finite R[X] E] : + Module.Finite R (LinearMap.ker (LinearMap.lsmul R[X] E X)) ∧ + Module.Finite R (E ⧸ LinearMap.range (LinearMap.lsmul R[X] E X)) := by + let f : Module.End R[X] E := LinearMap.lsmul R[X] E X + constructor + · apply finite_of_variable_annihilates + intro z + apply Subtype.ext + exact LinearMap.mem_ker.mp z.property + · apply finite_of_variable_annihilates + intro z + induction z using Submodule.Quotient.induction_on with + | _ z => + rw [← Submodule.Quotient.mk_smul, Submodule.Quotient.mk_eq_zero] + exact ⟨z, rfl⟩ + +end AlgebraicAnalysis.MonicAnnihilatorFinite diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulFiniteTorsion.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulFiniteTorsion.lean new file mode 100644 index 0000000000..c1ec0f4394 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulFiniteTorsion.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity + +/-! +# Finite power torsion for a principal Koszul endomorphism + +This file isolates the reusable algebra needed after tangential localization. +The ambient module need not be finite over the ring in which lengths are +measured. It is enough that the first kernel has finite length: all finite +power kernels then have finite length by devissage. + +The final theorem deliberately assumes that the actual residual quotient is +nonzero. It proves only the strict length inequality and makes no +noncharacteristic-support or geometric nonvanishing claim. +-/ + +namespace AlgebraicAnalysis.PrincipalKoszulFiniteTorsion + +open AlgebraicAnalysis.PrincipalKoszulPositivity + +noncomputable section + +universe u v + +variable {R : Type u} {E : Type v} +variable [CommRing R] +variable [AddCommGroup E] [Module R E] + +/-- If the first kernel of an endomorphism is Noetherian, then so is the +kernel of every finite power. No finiteness hypothesis is imposed on the +ambient module. -/ +theorem isNoetherian_kernel_power (f : Module.End R E) + [IsNoetherian R f.ker] (n : ℕ) : IsNoetherian R (f ^ n).ker := by + induction n with + | zero => + rw [pow_zero, Module.End.one_eq_id, LinearMap.ker_id] + infer_instance + | succ n ih => + let := ih + have hle : f.ker ≤ (f ^ (n + 1)).ker := by + intro z hz + rw [LinearMap.mem_ker, pow_succ, Module.End.mul_apply, + LinearMap.mem_ker.mp hz, map_zero] + let i : f.ker →ₗ[R] (f ^ (n + 1)).ker := Submodule.inclusion hle + let g : (f ^ (n + 1)).ker →ₗ[R] (f ^ n).ker := f.restrict (by + intro z hz + rw [LinearMap.mem_ker] at hz ⊢ + simpa [pow_succ, Module.End.mul_apply] using hz) + have hexact : i.range = g.ker := by + ext z + constructor + · rintro ⟨w, rfl⟩ + apply Subtype.ext + exact LinearMap.mem_ker.mp w.property + · intro hz + have hz0 : f z.val = 0 := congrArg Subtype.val (LinearMap.mem_ker.mp hz) + exact ⟨⟨z.val, hz0⟩, rfl⟩ + exact isNoetherian_of_range_eq_ker i g hexact + +/-- Finite length of the first kernel propagates to every finite power +kernel, even when the ambient module is not finite over `R`. -/ +theorem isFiniteLength_kernel_power (f : Module.End R E) + (hfinite : IsFiniteLength R f.ker) (n : ℕ) : + IsFiniteLength R (f ^ n).ker := by + have hfirst := isFiniteLength_iff_isNoetherian_isArtinian.mp hfinite + let : IsNoetherian R f.ker := hfirst.1 + let : IsArtinian R f.ker := hfirst.2 + exact isFiniteLength_iff_isNoetherian_isArtinian.mpr + ⟨isNoetherian_kernel_power f n, isArtinian_kernel_power f n⟩ + +/-- A stable finite power kernel contributes the same length to the kernel and +cokernel. If the actual quotient left after removing that torsion and the +range is nonzero, the principal Koszul Euler length is strictly positive. + +The nonzero quotient is an explicit input; this theorem does not manufacture +it from a support or noncharacteristic hypothesis. -/ +theorem length_cokernel_gt_kernel_of_stable_power_and_nonzero + (f : Module.End R E) (n : ℕ) + (hfinite : IsFiniteLength R f.ker) + (hstable : LinearMap.ker (f ^ n) = LinearMap.ker (f ^ (n + 1))) + (hnonzero : Nontrivial (E ⧸ ((f ^ n).ker ⊔ f.range))) : + Module.length R (E ⧸ f.range) > Module.length R f.ker := by + have hfirstparts := isFiniteLength_iff_isNoetherian_isArtinian.mp hfinite + let : IsNoetherian R f.ker := hfirstparts.1 + let : IsArtinian R f.ker := hfirstparts.2 + let T : Submodule R E := (f ^ n).ker + have hTfinite : IsFiniteLength R T := isFiniteLength_kernel_power f hfinite n + have hTparts := isFiniteLength_iff_isNoetherian_isArtinian.mp hTfinite + let : IsNoetherian R T := hTparts.1 + let : IsArtinian R T := hTparts.2 + have hcomap : T.comap f = T := by + ext z + rw [Submodule.mem_comap] + change (f ^ n) (f z) = 0 ↔ (f ^ n) z = 0 + rw [← Module.End.mul_apply, (Commute.self_pow f n).eq.symm, + Module.End.mul_apply] + simpa [Module.End.pow_apply, Function.iterate_succ_apply'] using + congrArg (fun K : Submodule R E ↦ z ∈ K) hstable.symm + let : Nontrivial (E ⧸ (T ⊔ f.range)) := hnonzero + have hpositive : 0 < Module.length R (E ⧸ (T ⊔ f.range)) := + Module.length_pos + rw [length_cokernel_eq_kernel_add_regular_quotient f T hcomap] + simpa [add_comm] using + ENat.lt_add_left (Module.length_ne_top (R := R) (M := f.ker)) hpositive + + +end + +end AlgebraicAnalysis.PrincipalKoszulFiniteTorsion diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulMinimalSupportPositivity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulMinimalSupportPositivity.lean new file mode 100644 index 0000000000..3b1a68f174 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulMinimalSupportPositivity.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulSupportOverBase +import Mathlib.RingTheory.Support + +/-! +# Principal Koszul positivity from minimal support + +The support primes used by the strict length argument are produced from the +finite `C`-module itself. In particular, no finiteness of `E` over the base +ring `R` is needed. +-/ + +namespace AlgebraicAnalysis.PrincipalKoszulMinimalSupportPositivity + +open AlgebraicAnalysis.PrincipalKoszulSupportOverBase + +noncomputable section + +universe u v w + +variable {R : Type u} {C : Type v} {E : Type w} +variable [CommRing R] [CommRing C] [Algebra R C] +variable [AddCommGroup E] [Module C E] [Module R E] +variable [IsScalarTower R C E] + +/-- Minimal support primes of `E` produce the ordered support pair needed by +the principal Koszul positivity argument. -/ +theorem length_cokernel_gt_kernel_of_minimal_support + [IsNoetherianRing C] [Module.Finite C E] + (x : C) + (hmin : ∀ p ∈ (Module.annihilator C E).minimalPrimes, + x ∉ p) + (hnonzero : Nontrivial (QuotSMulTop x E)) + (hfinite : IsFiniteLength R + (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R))) : + Module.length R (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R)) > + Module.length R (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R)) := by + have : Nontrivial (QuotSMulTop x E) := hnonzero + obtain ⟨q, hqquot⟩ := Module.nonempty_support_of_nontrivial + (R := C) (M := QuotSMulTop x E) + have hq := hqquot + rw [Module.support_quotSMulTop] at hq + have hqE : q ∈ Module.support C E := hq.1 + have han : Module.annihilator C E ≤ q.asIdeal := + Module.mem_support_iff_of_finite.mp hqE + obtain ⟨p, hpmin, hpq⟩ := + Ideal.exists_minimalPrimes_le (I := Module.annihilator C E) + (J := q.asIdeal) han + let p' : PrimeSpectrum C := ⟨p, hpmin.1.1⟩ + have hp' : p' ∈ Module.support C E := + Module.mem_support_iff_of_finite.mpr hpmin.1.2 + have hpq' : p' ≤ q := hpq + have hxp : x ∉ p'.asIdeal := by + exact hmin p hpmin + exact length_cokernel_gt_kernel_of_support_over_base + x p' q hp' hpq' hxp hqquot hfinite + + +end +end AlgebraicAnalysis.PrincipalKoszulMinimalSupportPositivity diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulPositivity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulPositivity.lean new file mode 100644 index 0000000000..b1912475a6 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulPositivity.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization +import Mathlib.RingTheory.Length +import Mathlib.RingTheory.Noetherian.Defs + +/-! +# Positivity for a principal Koszul quotient + +Stable power torsion contributes equally to kernel and cokernel length. +After removing it, local Nakayama gives a positive residual cokernel when +a support prime avoids the scalar. The proof retains embedded torsion; +it does not infer injectivity from minimal-prime avoidance. +-/ + +namespace AlgebraicAnalysis.PrincipalKoszulPositivity + +open scoped Pointwise + +noncomputable section + +universe u v + +variable {R : Type u} {E : Type v} +variable [CommRing R] +variable [AddCommGroup E] [Module R E] + +private abbrev scalarEnd (x : R) : E →ₗ[R] E := LinearMap.lsmul R E x + +/-- +The `x`-power torsion in a Noetherian module is already the kernel of one +finite power of `x`. This is the stabilization step needed before passing to +the quotient on which `x` acts injectively; it does not discard embedded +torsion. +-/ +theorem exists_stable_kernel_power [IsNoetherian R E] (f : Module.End R E) : + ∃ n : ℕ, LinearMap.ker (f ^ n) = LinearMap.ker (f ^ (n + 1)) := by + obtain ⟨n, hn⟩ := + (monotone_stabilizes_iff_noetherian.mpr (inferInstance : IsNoetherian R E)) + f.iterateKer + exact ⟨n, hn (n + 1) (Nat.le_add_right n 1)⟩ + +/-- Specialization of kernel stabilization to multiplication by a scalar. -/ +theorem exists_stable_kernel_power_smul [IsNoetherian R E] (x : R) : + ∃ n : ℕ, + LinearMap.ker ((scalarEnd (E := E) x) ^ n) = + LinearMap.ker ((scalarEnd (E := E) x) ^ (n + 1)) := + exists_stable_kernel_power (scalarEnd (E := E) x) + +/-- Finite-length coordinate kernel controls all finite power-torsion layers. +The Artinian assertion is the nontrivial half; Noetherianity is inherited +from the ambient finite module in the applications. -/ +theorem isArtinian_kernel_power (f : Module.End R E) + [IsArtinian R f.ker] (n : ℕ) : IsArtinian R (f ^ n).ker := by + induction n with + | zero => + rw [pow_zero, Module.End.one_eq_id, LinearMap.ker_id] + infer_instance + | succ n ih => + let := ih + have hle : f.ker ≤ (f ^ (n + 1)).ker := by + intro z hz + rw [LinearMap.mem_ker, pow_succ, Module.End.mul_apply, + LinearMap.mem_ker.mp hz, map_zero] + let i : f.ker →ₗ[R] (f ^ (n + 1)).ker := Submodule.inclusion hle + let g : (f ^ (n + 1)).ker →ₗ[R] (f ^ n).ker := f.restrict (by + intro z hz + rw [LinearMap.mem_ker] at hz ⊢ + simpa [pow_succ, Module.End.mul_apply] using hz) + have hexact : i.range = g.ker := by + ext z + constructor + · rintro ⟨w, rfl⟩ + apply Subtype.ext + exact LinearMap.mem_ker.mp w.property + · intro hz + have hz0 : f z.val = 0 := congrArg Subtype.val (LinearMap.mem_ker.mp hz) + exact ⟨⟨z.val, hz0⟩, rfl⟩ + exact isArtinian_of_range_eq_ker i g hexact + +/-- Once two consecutive power kernels agree, the induced endomorphism on +the quotient by the stabilized kernel is injective. -/ +theorem quotient_by_stable_kernel_power_injective (f : Module.End R E) (n : ℕ) + (hstable : LinearMap.ker (f ^ n) = LinearMap.ker (f ^ (n + 1))) : + Function.Injective + ((LinearMap.ker (f ^ n)).mapQ (LinearMap.ker (f ^ n)) f (by + intro z hz + change f z ∈ LinearMap.ker (f ^ n) + rw [LinearMap.mem_ker] at hz ⊢ + rw [← Module.End.mul_apply, (Commute.self_pow f n).eq.symm, + Module.End.mul_apply, hz, f.map_zero])) := by + rw [← LinearMap.ker_eq_bot, Submodule.ker_mapQ] + have hcomap : + (LinearMap.ker (f ^ n)).comap f = LinearMap.ker (f ^ n) := by + ext z + rw [Submodule.mem_comap] + change (f ^ n) (f z) = 0 ↔ (f ^ n) z = 0 + rw [← Module.End.mul_apply, (Commute.self_pow f n).eq.symm, + Module.End.mul_apply] + simpa [Module.End.pow_apply, Function.iterate_succ_apply'] using + congrArg (fun K : Submodule R E ↦ z ∈ K) hstable.symm + rw [hcomap] + simp + +/-- Removing a finite-length invariant submodule on which all failure of +injectivity is concentrated preserves the principal Koszul Euler length. +The hypothesis `T.comap f = T` says precisely that the quotient action is +injective; it does not assert injectivity on the original module. -/ +theorem length_cokernel_eq_kernel_add_regular_quotient + (f : Module.End R E) (T : Submodule R E) + [IsNoetherian R T] [IsArtinian R T] (hT : T.comap f = T) : + Module.length R (E ⧸ f.range) = + Module.length R f.ker + Module.length R (E ⧸ (T ⊔ f.range)) := by + have hstable : ∀ z ∈ T, f z ∈ T := by + intro z hz + exact show z ∈ T.comap f from hT.symm ▸ hz + let fT : Module.End R T := f.restrict hstable + have hpre : f.range.comap T.subtype = fT.range := by + ext z + constructor + · rintro ⟨w, hw⟩ + have hwT : w ∈ T := by + rw [← hT] + exact show f w ∈ T from hw ▸ z.property + exact ⟨⟨w, hwT⟩, Subtype.ext hw⟩ + · rintro ⟨w, rfl⟩ + exact ⟨w.val, rfl⟩ + let i : (T ⧸ fT.range) →ₗ[R] (E ⧸ f.range) := + fT.range.mapQ f.range T.subtype hpre.ge + let j : (E ⧸ f.range) →ₗ[R] (E ⧸ (T ⊔ f.range)) := + f.range.mapQ (T ⊔ f.range) LinearMap.id le_sup_right + have hi : Function.Injective i := by + rw [← LinearMap.ker_eq_bot] + dsimp [i] + rw [Submodule.ker_mapQ, hpre, Submodule.mkQ_map_self] + have hj : Function.Surjective j := by + rw [← LinearMap.range_eq_top] + simp [j, Submodule.range_mapQ] + have hexact : Function.Exact i j := by + rw [LinearMap.exact_iff] + simp [i, j, Submodule.range_mapQ, Submodule.ker_mapQ, + Submodule.map_sup, Submodule.mkQ_map_self] + have hsum := Module.length_eq_add_of_exact i j hi hj hexact + have hkerle : f.ker ≤ T := by + intro z hz + rw [← hT] + change f z ∈ T + rw [LinearMap.mem_ker.mp hz] + exact T.zero_mem + have hker : Module.length R fT.ker = Module.length R f.ker := by + have hk : fT.ker = f.ker.comap T.subtype := by + simp [fT, LinearMap.ker_restrict] + rw [hk] + exact (Submodule.comapSubtypeEquivOfLe hkerle).length_eq + have hsource := Module.length_eq_add_of_exact fT.ker.subtype fT.rangeRestrict + (Submodule.subtype_injective _) + (LinearMap.range_eq_top.mp (LinearMap.range_rangeRestrict fT)) + (by rw [LinearMap.exact_iff, Submodule.range_subtype, LinearMap.ker_rangeRestrict]) + have htarget := Module.length_eq_add_of_exact fT.range.subtype fT.range.mkQ + (Submodule.subtype_injective _) (Submodule.mkQ_surjective _) + (LinearMap.exact_subtype_mkQ _) + have hcancel : Module.length R (T ⧸ fT.range) = Module.length R fT.ker := by + have hfinite : Module.length R fT.range ≠ ⊤ := Module.length_ne_top + apply ENat.add_left_injective_of_ne_top hfinite + change Module.length R (T ⧸ fT.range) + Module.length R fT.range = + Module.length R fT.ker + Module.length R fT.range + rw [add_comm (Module.length R (T ⧸ fT.range)), ← htarget] + exact hsource + rw [hcancel, hker] at hsum + exact hsum + +/-- A maximal-ideal scalar has a proper image on a nonzero finite module. -/ +theorem scalar_range_ne_top_of_mem_maximalIdeal + [IsLocalRing R] [Module.Finite R E] [Nontrivial E] + {x : R} (hx : x ∈ IsLocalRing.maximalIdeal R) : + (scalarEnd (E := E) x).range ≠ (⊤ : Submodule R E) := by + have hann : Module.annihilator R E ≠ ⊤ := by + intro h + exact not_subsingleton_iff_nontrivial.mpr inferInstance + (Module.annihilator_eq_top_iff.mp h) + have hspan : Ideal.span ({x} : Set R) ≤ + (Module.annihilator R E).jacobson := by + rw [Ideal.span_singleton_le_iff_mem] + rw [IsLocalRing.jacobson_eq_maximalIdeal _ hann] + exact hx + have hsmul : (⊤ : Submodule R E) ≠ Ideal.span ({x} : Set R) • (⊤ : Submodule R E) := + Submodule.top_ne_ideal_smul_of_le_jacobson_annihilator hspan + intro hrange + apply hsmul + have hEq : (scalarEnd (E := E) x).range = + Ideal.span ({x} : Set R) • (⊤ : Submodule R E) := by + ext y + constructor + · rintro ⟨z, rfl⟩ + exact Submodule.smul_mem_smul (Submodule.subset_span (Set.mem_singleton x)) + (Submodule.mem_top) + · intro hy + refine Submodule.smul_induction_on hy ?_ (fun a b ha hb => ?_) + · intro r hr z hz + rcases (Ideal.mem_span_singleton.mp hr) with ⟨c, rfl⟩ + refine ⟨c • z, ?_⟩ + simp [scalarEnd, smul_smul, mul_comm] + · exact add_mem (by assumption) (by assumption) + exact hrange.symm.trans hEq + +/-- +If multiplication by `x` is injective on a nonzero finite local module and +its cokernel has finite length, then the cokernel has strictly larger length +than the kernel. The quotient is nonzero by Nakayama, so the conclusion is +genuine positivity rather than an axiom-shaped length assumption. + +This is only the regular (torsion-free) specialization of the stabilized +`x`-power-torsion cancellation argument. Minimal-support avoidance alone +does not imply its injectivity hypothesis when embedded torsion is present. +-/ +theorem length_cokernel_smul_gt_length_kernel_smul + [IsLocalRing R] [Module.Finite R E] [Nontrivial E] {x : R} + (hx : x ∈ IsLocalRing.maximalIdeal R) + (hinj : Function.Injective (scalarEnd (E := E) x)) + (_hfinite : IsFiniteLength R (E ⧸ (scalarEnd (E := E) x).range)) : + Module.length R (E ⧸ (scalarEnd (E := E) x).range) > + Module.length R (scalarEnd (E := E) x).ker := by + have hker : (scalarEnd (E := E) x).ker = ⊥ := by + apply le_antisymm + · intro y hy + apply hinj + simpa using (LinearMap.mem_ker.mp hy) + · exact bot_le + have hq : Nontrivial (E ⧸ (scalarEnd (E := E) x).range) := + Submodule.Quotient.nontrivial_iff.mpr + (scalar_range_ne_top_of_mem_maximalIdeal hx) + rw [hker, Module.length_bot] + exact Module.length_pos + +/-- Embedded scalar-power torsion may be retained: after its finite-length +Euler contribution is cancelled, any nonzero regular quotient contributes +strictly positively by Nakayama. -/ +theorem length_cokernel_smul_gt_kernel_of_finite_torsion + [IsLocalRing R] [Module.Finite R E] + {x : R} (hx : x ∈ IsLocalRing.maximalIdeal R) + (T : Submodule R E) [IsNoetherian R T] [IsArtinian R T] + (hT : T.comap (scalarEnd (E := E) x) = T) (hproper : T ≠ ⊤) : + Module.length R (E ⧸ (scalarEnd (E := E) x).range) > + Module.length R (scalarEnd (E := E) x).ker := by + let f := scalarEnd (E := E) x + have hstable : T ≤ T.comap f := hT.ge + let g : Module.End R (E ⧸ T) := T.mapQ T f hstable + have hg : g = scalarEnd (E := E ⧸ T) x := by + ext z + rfl + have hrange : g.range = f.range.map T.mkQ := Submodule.range_mapQ _ _ _ _ + let : Nontrivial (E ⧸ T) := Submodule.Quotient.nontrivial_iff.mpr hproper + have hnontop : f.range.map T.mkQ ≠ ⊤ := by + rw [← hrange, hg] + exact scalar_range_ne_top_of_mem_maximalIdeal hx + let : Nontrivial ((E ⧸ T) ⧸ f.range.map T.mkQ) := + Submodule.Quotient.nontrivial_iff.mpr hnontop + have hpositive : 0 < Module.length R (E ⧸ (T ⊔ f.range)) := by + rw [← (Submodule.quotientQuotientEquivQuotientSup T f.range).length_eq] + exact Module.length_pos + have hkerle : f.ker ≤ T := by + intro z hz + rw [← hT] + change f z ∈ T + rw [LinearMap.mem_ker.mp hz] + exact T.zero_mem + let : IsNoetherian R f.ker := + isNoetherian_of_injective (Submodule.inclusion hkerle) + (Submodule.inclusion_injective hkerle) + let : IsArtinian R f.ker := + isArtinian_of_injective (Submodule.inclusion hkerle) + (Submodule.inclusion_injective hkerle) + rw [length_cokernel_eq_kernel_add_regular_quotient f T hT] + simpa [add_comm] using ENat.lt_add_left (Module.length_ne_top (R := R) (M := f.ker)) hpositive + +/-- Principal Koszul positivity, including embedded torsion. A support prime +not containing `x` guarantees a nonzero regular quotient; finite length of +the coordinate kernel makes the discarded power torsion finite length. -/ +theorem length_cokernel_smul_gt_kernel_of_support_prime + [IsLocalRing R] [Module.Finite R E] [IsNoetherian R E] + {x : R} (hx : x ∈ IsLocalRing.maximalIdeal R) + [IsArtinian R (scalarEnd (E := E) x).ker] + (P : Ideal R) (hP : P.IsPrime) + (hann : Module.annihilator R E ≤ P) (hxP : x ∉ P) : + Module.length R (E ⧸ (scalarEnd (E := E) x).range) > + Module.length R (scalarEnd (E := E) x).ker := by + let f := scalarEnd (E := E) x + obtain ⟨n, hn⟩ := exists_stable_kernel_power f + let T := (f ^ n).ker + let : IsArtinian R T := isArtinian_kernel_power f n + have hcomap : T.comap f = T := by + ext z + rw [Submodule.mem_comap] + change (f ^ n) (f z) = 0 ↔ (f ^ n) z = 0 + rw [← Module.End.mul_apply, (Commute.self_pow f n).eq.symm, + Module.End.mul_apply] + simpa [Module.End.pow_apply, Function.iterate_succ_apply'] using + congrArg (fun K : Submodule R E ↦ z ∈ K) hn.symm + have hpower : ∀ m (z : E), (f ^ m) z = x ^ m • z := by + intro m + induction m with + | zero => intro z; simp + | succ m ih => + intro z + simp [pow_succ, Module.End.mul_apply, ih, f, scalarEnd, smul_smul] + have hproper : T ≠ ⊤ := by + intro htop + apply hxP + apply hP.mem_of_pow_mem n + apply hann + rw [Module.mem_annihilator] + intro z + rw [← hpower n z] + exact LinearMap.mem_ker.mp (show z ∈ T by rw [htop]; trivial) + exact length_cokernel_smul_gt_kernel_of_finite_torsion hx T hcomap hproper + + +end +end AlgebraicAnalysis.PrincipalKoszulPositivity diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulSupportOverBase.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulSupportOverBase.lean new file mode 100644 index 0000000000..d9d08d5a78 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/PrincipalKoszulSupportOverBase.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StableTorsionResidualSupport +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulFiniteTorsion + +/-! +# Principal Koszul positivity after restriction of scalars + +Support and torsion are computed over the coefficient algebra `C`; the +resulting length inequality is measured over the base ring `R`. No finite +generation of `E` over `R` is needed: only the first `R`-kernel has finite +length. +-/ + +namespace AlgebraicAnalysis.PrincipalKoszulSupportOverBase + +open AlgebraicAnalysis.PrincipalKoszulPositivity +open AlgebraicAnalysis.PrincipalKoszulFiniteTorsion +open AlgebraicAnalysis.StableTorsionResidualSupport + +noncomputable section + +universe u v w + +variable {R : Type u} {C : Type v} {E : Type w} +variable [CommRing R] [CommRing C] [Algebra R C] +variable [AddCommGroup E] [Module C E] [Module R E] +variable [IsScalarTower R C E] + +theorem length_cokernel_gt_kernel_of_support_over_base + [IsNoetherianRing C] [Module.Finite C E] + (x : C) (p q : PrimeSpectrum C) + (hp : p ∈ Module.support C E) (hpq : p ≤ q) + (hxp : x ∉ p.asIdeal) + (hq : q ∈ Module.support C (QuotSMulTop x E)) + (hfinite : IsFiniteLength R + (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R))) : + Module.length R (E ⧸ LinearMap.range ((LinearMap.lsmul C E x).restrictScalars R)) > + Module.length R (LinearMap.ker ((LinearMap.lsmul C E x).restrictScalars R)) := by + let fC : Module.End C E := LinearMap.lsmul C E x + let fR : Module.End R E := fC.restrictScalars R + obtain ⟨n, hn⟩ := exists_stable_kernel_power_smul (E := E) x + have hpow : ∀ m, fR ^ m = (fC ^ m).restrictScalars R := by + intro m + induction m with + | zero => ext z; simp + | succ m ih => + rw [pow_succ, pow_succ, ih] + ext z + simp [fR, LinearMap.restrictScalars_apply, Module.End.mul_apply] + have hstable : LinearMap.ker (fR ^ n) = LinearMap.ker (fR ^ (n + 1)) := by + rw [hpow, hpow, LinearMap.ker_restrictScalars, LinearMap.ker_restrictScalars] + exact congrArg (Submodule.restrictScalars R) hn + have hnonzeroC : Nontrivial (E ⧸ (LinearMap.ker (fC ^ n) ⊔ fC.range)) := + residual_nontrivial_of_support x n p q hp hpq hxp hq + let PC : Submodule C E := LinearMap.ker (fC ^ n) ⊔ fC.range + let PR : Submodule R E := LinearMap.ker (fR ^ n) ⊔ fR.range + have hPR : PR = PC.restrictScalars R := by + dsimp [PR, PC] + rw [show fR ^ n = (fC ^ n).restrictScalars R from hpow n] + simp only [LinearMap.ker_restrictScalars, Submodule.restrictScalars_sup] + rfl + have hnonzeroR : Nontrivial (E ⧸ PR) := by + have hPC : PC ≠ (⊤ : Submodule C E) := + Submodule.Quotient.nontrivial_iff.mp hnonzeroC + apply Submodule.Quotient.nontrivial_iff.mpr + intro htop + apply hPC + apply (Submodule.restrictScalars_eq_top_iff R C E).mp + rw [← hPR, htop] + have hresult := + length_cokernel_gt_kernel_of_stable_power_and_nonzero + (R := R) fR n hfinite hstable hnonzeroR + simpa [fR, fC] using hresult + + +end +end AlgebraicAnalysis.PrincipalKoszulSupportOverBase diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankExact.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankExact.lean new file mode 100644 index 0000000000..7dce1e05d6 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankExact.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.RankTorsion +import Mathlib.LinearAlgebra.Dimension.DivisionRing + +/-! +# Rank additivity for split sequences + +Packet 2 cannot currently assert that noncommutative Ore localization is flat: +the pinned Mathlib has no such theorem. This file therefore proves the exact +additivity statements that require only an explicit linear equivalence after +localization. In particular, whenever a localized short exact sequence is +known to split, its localized middle term is equivalent to a product and the +rank is additive. No flatness or exactness interface is postulated here. +-/ + +namespace AlgebraicAnalysis +namespace RankExact + +open OreLocalization +open nonZeroDivisors + +universe u v + +section DivisionRing + +variable {Q : Type u} [DivisionRing Q] +variable {V W : Type v} [AddCommGroup V] [Module Q V] +variable [AddCommGroup W] [Module Q W] + +theorem rank_prod_add : + Module.rank Q (V × W) = Module.rank Q V + Module.rank Q W := by + exact rank_prod' + +theorem rank_add_of_linearEquiv_prod {U : Type v} + [AddCommGroup U] [Module Q U] + (e : U ≃ₗ[Q] V × W) : + Module.rank Q U = Module.rank Q V + Module.rank Q W := by + rw [e.rank_eq, rank_prod_add] + +theorem rank_add_of_split_exact + {U : Type v} [AddCommGroup U] [Module Q U] + (i : V →ₗ[Q] U) (p : U →ₗ[Q] W) + (r : U →ₗ[Q] V) (s : W →ₗ[Q] U) + (hri : r.comp i = LinearMap.id) + (hps : p.comp s = LinearMap.id) + (hpi : p.comp i = 0) + (hrs : r.comp s = 0) + (hdecomp : i.comp r + s.comp p = LinearMap.id) : + Module.rank Q U = Module.rank Q V + Module.rank Q W := by + let f : U →ₗ[Q] V × W := LinearMap.prod r p + let g : V × W →ₗ[Q] U := LinearMap.coprod i s + have hgf : g.comp f = LinearMap.id := by + ext u + change i (r u) + s (p u) = u + exact LinearMap.congr_fun hdecomp u + have hfg : f.comp g = LinearMap.id := by + apply LinearMap.ext + intro z + rcases z with ⟨v, w⟩ + apply Prod.ext + · change r (i v + s w) = v + rw [map_add] + have hri' : r (i v) = v := by + simpa only [LinearMap.comp_apply, LinearMap.id_apply] using + LinearMap.congr_fun hri v + have hrs' : r (s w) = 0 := by + simpa only [LinearMap.comp_apply, LinearMap.zero_apply] using + LinearMap.congr_fun hrs w + rw [hri', hrs', add_zero] + · change p (i v + s w) = w + rw [map_add] + have hpi' : p (i v) = 0 := by + simpa only [LinearMap.comp_apply, LinearMap.zero_apply] using + LinearMap.congr_fun hpi v + have hps' : p (s w) = w := by + simpa only [LinearMap.comp_apply, LinearMap.id_apply] using + LinearMap.congr_fun hps w + rw [hpi', hps', zero_add] + have hf : Function.Bijective f := by + constructor + · intro u₁ u₂ h + have hgfu (u : U) : g (f u) = u := by + simpa only [LinearMap.comp_apply, LinearMap.id_apply] using + LinearMap.congr_fun hgf u + calc + u₁ = g (f u₁) := (hgfu u₁).symm + _ = g (f u₂) := congrArg g h + _ = u₂ := hgfu u₂ + · intro z + have hfgz (z : V × W) : f (g z) = z := by + simpa only [LinearMap.comp_apply, LinearMap.id_apply] using + LinearMap.congr_fun hfg z + exact ⟨g z, hfgz z⟩ + exact rank_add_of_linearEquiv_prod (LinearEquiv.ofBijective f hf) + +theorem finrank_prod_add [Module.Finite Q V] [Module.Finite Q W] : + Module.finrank Q (V × W) = Module.finrank Q V + Module.finrank Q W := by + exact Module.finrank_prod + +@[nolint unusedArguments] +theorem finrank_add_of_linearEquiv_prod {U : Type v} + [AddCommGroup U] [Module Q U] [Module.Finite Q U] + [Module.Finite Q V] [Module.Finite Q W] + (e : U ≃ₗ[Q] V × W) : + Module.finrank Q U = Module.finrank Q V + Module.finrank Q W := by + rw [e.finrank_eq, finrank_prod_add] + +end DivisionRing + +section LocalizedOre + +variable {R : Type u} [Ring R] [Nontrivial R] [NoZeroDivisors R] +variable [OreLocalization.OreSet (Rᵐᵒᵖ)⁰] +variable {M N P : Type v} +variable [AddCommGroup M] [Module Rᵐᵒᵖ M] +variable [AddCommGroup N] [Module Rᵐᵒᵖ N] +variable [AddCommGroup P] [Module Rᵐᵒᵖ P] + +open AlgebraicAnalysis.RankTorsion + +theorem oreRank_add_of_localized_prod_equiv + (e : LocalizedRightModule R M ≃ₗ[FractionRingOp R] + (LocalizedRightModule R N × LocalizedRightModule R P)) : + oreRank (R := R) M = oreRank (R := R) N + oreRank (R := R) P := by + rw [oreRank_eq_rank_localized, e.rank_eq, rank_prod_add, + oreRank_eq_rank_localized, oreRank_eq_rank_localized] + +end LocalizedOre + + +end RankExact +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankTorsion.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankTorsion.lean new file mode 100644 index 0000000000..4a1e750263 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RankTorsion.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.OreLocalization.Ring +import Mathlib.LinearAlgebra.Dimension.DivisionRing +import Mathlib.LinearAlgebra.Dimension.Torsion.Finite + +/-! +# Rank and torsion over Ore localizations + +This file contains the part of handover packet 2 which is available without +postulating a noncommutative flatness theorem. A right `R`-module is encoded +as a left `Rᵐᵒᵖ`-module. When the right Ore condition needed for this +localization holds, its Ore localization is a module over the division ring +of fractions of `Rᵐᵒᵖ`; `oreRank` is the ordinary vector-space rank of that +localization. + +The pinned Mathlib has the Ore localization and its division-ring structure, +but not the noncommutative tensor/localization exactness theorem (the +commutative tensor-product exactness file explicitly lists this as TODO). +Consequently this file proves the rank-nullity and torsion criteria for the +localized division-ring module, and records the exact first missing bridge: +that localization sends an arbitrary short exact sequence of right +`R`-modules to a short exact sequence. No proposition in this file assumes +that bridge or introduces an axiom for it. + +The commutative-domain criterion `rank_eq_zero_iff_isTorsion` imported from +Mathlib remains available, but is deliberately not reused as a theorem about +noncommutative `R`. +-/ + +namespace AlgebraicAnalysis +namespace RankTorsion + +open nonZeroDivisors +open OreLocalization + +universe u v + +section DivisionRingRank + +variable {Q : Type u} [DivisionRing Q] +variable {V V' : Type v} [AddCommGroup V] [Module Q V] +variable [AddCommGroup V'] [Module Q V'] + +/-! ## Unconditional vector-space rank facts -/ + +theorem rank_quotient_add_rank (P : Submodule Q V) : + Module.rank Q (V ⧸ P) + Module.rank Q P = Module.rank Q V := + rank_quotient_add_rank_of_divisionRing P + +theorem rank_eq_zero_iff_subsingleton : + Module.rank Q V = 0 ↔ Subsingleton V := by + exact rank_zero_iff + +theorem rank_eq_zero_iff_forall_zero : + Module.rank Q V = 0 ↔ ∀ v : V, v = 0 := by + constructor + · intro h v + letI : Subsingleton V := (rank_zero_iff.mp h) + exact Subsingleton.elim v 0 + · intro h + apply rank_zero_iff.mpr + exact ⟨fun x y => (h x).trans (h y).symm⟩ + +theorem rank_eq_zero_iff_isTorsionOverDivisionRing : + Module.rank Q V = 0 ↔ + (∀ v : V, ∃ a : Q, a ≠ 0 ∧ a • v = 0) := by + exact rank_eq_zero_iff + +theorem finrank_quotient_add_finrank [Module.Finite Q V] (P : Submodule Q V) : + Module.finrank Q (V ⧸ P) + Module.finrank Q P = Module.finrank Q V := + P.finrank_quotient_add_finrank + +theorem rank_eq_of_surjective (f : V →ₗ[Q] V') (hf : Function.Surjective f) : + Module.rank Q V = Module.rank Q V' + Module.rank Q (LinearMap.ker f) := + LinearMap.rank_eq_of_surjective hf + +@[nolint unusedArguments] +theorem finrank_eq_of_surjective [Module.Finite Q V] + [Module.Finite Q V'] (f : V →ₗ[Q] V') (hf : Function.Surjective f) : + Module.finrank Q V = Module.finrank Q V' + + Module.finrank Q (LinearMap.ker f) := by + have h := (LinearMap.ker f).finrank_quotient_add_finrank + rw [LinearEquiv.finrank_eq (LinearMap.quotKerEquivOfSurjective f hf)] at h + exact h.symm + +end DivisionRingRank + +section OreLocalizedRightModules + +/-! +`OreSet R⁰` is the left Ore condition. A right module is localized using the +opposite ring, so the corresponding right Ore condition is represented by an +explicit `OreSet (Rᵐᵒᵖ)⁰` assumption. This is intentional: left Ore alone does +not imply right Ore for a general domain. +-/ + +variable {R : Type u} [Ring R] [Nontrivial R] [NoZeroDivisors R] +variable [OreLocalization.OreSet (Rᵐᵒᵖ)⁰] +variable {M : Type v} [AddCommGroup M] [Module Rᵐᵒᵖ M] + +/-- The full Ore localization of the opposite coefficient ring. -/ +@[nolint unusedArguments] +abbrev FractionRingOp (R : Type u) [Ring R] [Nontrivial R] + [NoZeroDivisors R] [OreLocalization.OreSet (Rᵐᵒᵖ)⁰] := + (Rᵐᵒᵖ)[(Rᵐᵒᵖ)⁰⁻¹] + +/-- Localization of a right `R`-module, represented as a left opposite-module. -/ +@[nolint unusedArguments] +abbrev LocalizedRightModule (R : Type u) (M : Type v) + [Ring R] [Nontrivial R] [NoZeroDivisors R] + [OreLocalization.OreSet (Rᵐᵒᵖ)⁰] [AddCommGroup M] [Module Rᵐᵒᵖ M] := + M[(Rᵐᵒᵖ)⁰⁻¹] + +/-- The rank of a right module after passage to the full fraction ring. -/ +noncomputable def oreRank (M : Type v) [AddCommGroup M] [Module Rᵐᵒᵖ M] : Cardinal := + Module.rank (FractionRingOp R) (LocalizedRightModule R M) + +@[nolint unusedArguments] +theorem oreRank_eq_rank_localized : + oreRank (R := R) M = + Module.rank (FractionRingOp R) (LocalizedRightModule R M) := + rfl + +@[nolint unusedArguments] +theorem oreRank_eq_of_localizedLinearEquiv {N : Type v} + [AddCommGroup N] [Module Rᵐᵒᵖ N] + (e : LocalizedRightModule R M ≃ₗ[FractionRingOp R] + LocalizedRightModule R N) : + oreRank (R := R) M = oreRank (R := R) N := by + exact e.rank_eq + +@[nolint unusedArguments] +theorem localized_oreDiv_one_eq_zero_iff (m : M) : + (m /ₒ (1 : (Rᵐᵒᵖ)⁰) : LocalizedRightModule R M) = 0 ↔ + ∃ s : (Rᵐᵒᵖ)⁰, s • m = 0 := by + constructor + · intro h + rw [← OreLocalization.zero_oreDiv (1 : (Rᵐᵒᵖ)⁰)] at h + rw [OreLocalization.oreDiv_eq_iff] at h + rcases h with ⟨u, v, huv, hden⟩ + have hv : v = (u : Rᵐᵒᵖ) := by simpa using hden.symm + refine ⟨u, ?_⟩ + change (u : Rᵐᵒᵖ) • m = 0 + rw [← hv] + simpa using huv.symm + · rintro ⟨s, hs⟩ + change (s : Rᵐᵒᵖ) • m = 0 at hs + rw [← OreLocalization.zero_oreDiv (1 : (Rᵐᵒᵖ)⁰)] + rw [OreLocalization.oreDiv_eq_iff] + refine ⟨s, (s : Rᵐᵒᵖ), ?_, ?_⟩ + · simpa using hs.symm + · simp + +theorem oreRank_zero_iff_localized_subsingleton : + oreRank (R := R) M = 0 ↔ Subsingleton (LocalizedRightModule R M) := by + exact rank_zero_iff + +theorem oreRank_zero_iff_rightTorsion : + oreRank (R := R) M = 0 ↔ + (∀ m : M, ∃ s : (Rᵐᵒᵖ)⁰, s • m = 0) := by + rw [oreRank_zero_iff_localized_subsingleton] + constructor + · intro h m + have hz : (m /ₒ (1 : (Rᵐᵒᵖ)⁰) : LocalizedRightModule R M) = 0 := by + exact Subsingleton.elim _ _ + exact (localized_oreDiv_one_eq_zero_iff m).mp hz + · intro h + refine ⟨fun x y => ?_⟩ + have hzero : ∀ z : LocalizedRightModule R M, z = 0 := by + intro z + induction z using OreLocalization.ind with + | _ m s => + rw [← OreLocalization.zero_oreDiv (s : (Rᵐᵒᵖ)⁰)] + obtain ⟨t, ht⟩ := h m + change (t : Rᵐᵒᵖ) • m = 0 at ht + rw [OreLocalization.oreDiv_eq_iff] + refine ⟨t, (t : Rᵐᵒᵖ), ?_, ?_⟩ + · simpa using ht.symm + · simp + exact (hzero x).trans (hzero y).symm + +theorem oreRank_zero_iff_localized_torsion : + oreRank (R := R) M = 0 ↔ + (∀ z : LocalizedRightModule R M, + ∃ a : FractionRingOp R, a ≠ 0 ∧ a • z = 0) := by + exact rank_eq_zero_iff_isTorsionOverDivisionRing + + +end OreLocalizedRightModules + +end RankTorsion +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/RightCoordinates.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RightCoordinates.lean new file mode 100644 index 0000000000..8b8a06a2ce --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/RightCoordinates.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# The concrete right-coordinate model for a stage + +The iterated Ore tower currently supplies nested additive normal forms, but it +does not yet identify a localized stage with a free right module over its +coefficient stage. This file formalizes the part that is unconditional and +used once that identification is available: the canonical coordinatewise +right action on the free coordinate object `ι →₀ S`, together with its finite +single-coordinate decomposition. No freeness of an Ore localization is +assumed or encoded by an equivalent hypothesis here. +-/ + +namespace AlgebraicAnalysis.RightCoordinates + +noncomputable section + +variable {S ι α : Type*} [Ring S] + +/-- The coordinatewise right action on finitely supported `S`-coordinates. -/ +def rightCoordinateAction (v : ι →₀ S) (a : S) : ι →₀ S := + (MulOpposite.op a : Sᵐᵒᵖ) • v + +@[simp] theorem rightCoordinateAction_apply (v : ι →₀ S) (a : S) (i : ι) : + rightCoordinateAction v a i = v i * a := rfl + +@[simp] theorem rightCoordinateAction_eq_op_smul (v : ι →₀ S) (a : S) : + rightCoordinateAction v a = + (MulOpposite.op a : Sᵐᵒᵖ) • v := rfl + +/-- Coordinatewise right multiplication is additive in the vector. -/ +theorem rightCoordinateAction_add (v w : ι →₀ S) (a : S) : + rightCoordinateAction (v + w) a = + rightCoordinateAction v a + rightCoordinateAction w a := by + ext i + simp [rightCoordinateAction, add_mul] + +/-- Coordinatewise right multiplication is additive in the scalar. -/ +theorem rightCoordinateAction_add_scalar (v : ι →₀ S) (a b : S) : + rightCoordinateAction v (a + b) = + rightCoordinateAction v a + rightCoordinateAction v b := by + ext i + simp [rightCoordinateAction, mul_add] + +@[simp, nolint simpNF] theorem rightCoordinateAction_one (v : ι →₀ S) : + rightCoordinateAction v 1 = v := by + simpa only [rightCoordinateAction_eq_op_smul, MulOpposite.op_one, one_smul] + +/-- Written in right-sided order, successive coordinate actions multiply the +scalars in the same order. -/ +theorem rightCoordinateAction_mul (v : ι →₀ S) (a b : S) : + rightCoordinateAction (rightCoordinateAction v a) b = + rightCoordinateAction v (a * b) := by + ext i + simp [rightCoordinateAction, mul_assoc] + +/-- Coordinatewise right multiplication commutes with finite additive sums. -/ +theorem rightCoordinateAction_sum (t : Finset α) (f : α → ι →₀ S) (a : S) : + rightCoordinateAction (∑ j ∈ t, f j) a = + ∑ j ∈ t, rightCoordinateAction (f j) a := by + ext i + simp [rightCoordinateAction, Finset.sum_mul] + +/-- A single coordinate remains a single coordinate under the right action. -/ +theorem rightCoordinateAction_single (i : ι) (s a : S) : + rightCoordinateAction (Finsupp.single i s) a = + Finsupp.single i (s * a) := by + ext j + by_cases h : i = j + · subst j + simp [rightCoordinateAction] + · simp [rightCoordinateAction, h, Ne.symm h] + +/-- Every finitely supported coordinate vector is the finite sum of its pure +coordinate vectors. -/ +theorem rightCoordinate_decomposition (v : ι →₀ S) : + v = ∑ i ∈ v.support, Finsupp.single i (v i) := by + symm + exact Finsupp.sum_single v + +/-- After a right action, the finite coordinate decomposition is acted on +coordinatewise. -/ +theorem rightCoordinate_decomposition_action (v : ι →₀ S) (a : S) : + rightCoordinateAction v a = + ∑ i ∈ v.support, Finsupp.single i (v i * a) := by + calc + rightCoordinateAction v a = + rightCoordinateAction + (∑ i ∈ v.support, Finsupp.single i (v i)) a := by + exact congrArg (fun w => rightCoordinateAction w a) + (rightCoordinate_decomposition v) + _ = ∑ i ∈ v.support, + rightCoordinateAction (Finsupp.single i (v i)) a := by + rw [rightCoordinateAction_sum] + _ = ∑ i ∈ v.support, Finsupp.single i (v i * a) := by + simp_rw [rightCoordinateAction_single] + +/-- The canonical pure coordinates generate the free right-coordinate model. -/ +theorem rightCoordinate_eq_top_of_single_mem + (H : Submodule Sᵐᵒᵖ (ι →₀ S)) + (hH : ∀ i : ι, ∀ s : S, Finsupp.single i s ∈ H) : + H = ⊤ := by + apply top_unique + intro v hv + rw [rightCoordinate_decomposition v] + apply Submodule.sum_mem + intro i hi + exact hH i (v i) + + +end +end AlgebraicAnalysis.RightCoordinates diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/Splice.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/Splice.lean new file mode 100644 index 0000000000..41251d3df0 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/Splice.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Maximal-submodule splice + +These are lattice-theoretic module lemmas used by finite-length correction +arguments. They contain no finite-length, Ore, or differential-operator +assumption. The hypotheses that construct the relevant submodules remain +with the application. +-/ + +namespace AlgebraicAnalysis.Splice + +open Submodule + +variable {R M : Type*} [Ring R] [AddCommGroup M] [Module R M] + +/-- A simple layer turns a proper submodule whose sum with the layer is top +into a maximal submodule. -/ +theorem isCoatom_of_covBy_sup_eq_top + {N N' U : Submodule R M} + (hNU : N ≤ U) (hNN' : N ⋖ N') + (hsup : N' ⊔ U = ⊤) (hUtop : U ≠ ⊤) : + IsCoatom U := by + have hInfEq : N' ⊓ U = N := by + apply le_antisymm + · by_contra hnot + have hNInf : N ≤ N' ⊓ U := le_inf hNN'.le hNU + have hNe : N ≠ N' ⊓ U := by + intro hEq + apply hnot + rw [hEq] + rcases hNN'.eq_or_eq hNInf inf_le_left with hEq | hEq + · exact hnot (by rw [hEq]) + · have hN'leU : N' ≤ U := by + rw [← hEq] + exact inf_le_right + apply hUtop + calc + U = N' ⊔ U := (sup_eq_right.mpr hN'leU).symm + _ = ⊤ := hsup + · exact le_inf hNN'.le hNU + have hInfCov : U ⊓ N' ⋖ N' := by + simpa [inf_comm, hInfEq] using hNN' + have hCov : U ⋖ U ⊔ N' := covBy_sup_of_inf_covBy_right hInfCov + have hCov' : U ⋖ ⊤ := by + simpa [sup_comm, hsup] using hCov + exact hCov'.isCoatom + +/-- +The reusable maximal-submodule splice. Once a combined submodule contains a +simple layer and one of the maximal submodules, it is the whole module. +-/ +theorem maximal_submodule_splice + {N N' U V H : Submodule R M} + (hNU : N ≤ U) (hNV : N ≤ V) (hNN' : N ⋖ N') + (hsupU : N' ⊔ U = ⊤) (hUtop : U ≠ ⊤) + (hsupV : N' ⊔ V = ⊤) (hVtop : V ≠ ⊤) + (hVU : V ≤ U) (hUH : U ≤ H) (hN'H : N' ≤ H) : + H = ⊤ := by + have hUcoat : IsCoatom U := isCoatom_of_covBy_sup_eq_top hNU hNN' hsupU hUtop + have hVcoat : IsCoatom V := isCoatom_of_covBy_sup_eq_top hNV hNN' hsupV hVtop + have hUV : U = V := by + exact (hVcoat.le_iff_eq hUtop).mp hVU + have hVH : V ≤ H := by + rw [← hUV] + exact hUH + apply top_unique + rw [← hsupV] + exact sup_le hN'H hVH + +/-- +If `v` lies in `P` and some scalar multiple of a vector escapes `P`, then the +class of the corresponding affine correction generates the simple quotient. +-/ +theorem exists_affine_correction_mod_simple_quotient + {P : Submodule R M} (v : M) (hv : v ∈ P) + (hsimple : IsSimpleModule R (M ⧸ P)) (alpha : R) + (hescape : ∃ delta : M, alpha • delta ∉ P) : + ∃ delta : M, span R {P.mkQ (v - alpha • delta)} = ⊤ := by + obtain ⟨delta, hdelta⟩ := hescape + have hne : P.mkQ (v - alpha • delta) ≠ 0 := by + rw [Ne, Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + intro hmem + apply hdelta + have hsub := P.sub_mem hv hmem + simpa [sub_sub_cancel] using hsub + refine ⟨delta, ?_⟩ + rw [LinearMap.span_singleton_eq_range, LinearMap.range_eq_top] + exact IsSimpleModule.toSpanSingleton_surjective R hne + + +end AlgebraicAnalysis.Splice diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/SplitLatticePresentation.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/SplitLatticePresentation.lean new file mode 100644 index 0000000000..faf028a311 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/SplitLatticePresentation.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.LocalRing.Module +import Mathlib.LinearAlgebra.Matrix.Basis + +/-! +# Matrix coordinates for a finite-rank direct summand + +This file contains the coordinate-free-to-matrix step used by the general +tangent-limit criterion. A complemented submodule of a finite coordinate +module over a local ring is finite projective, hence finite free. Choosing a +basis only inside the proof produces a column matrix and a retraction matrix. +The matrices split, and their columns span exactly the original submodule. +-/ + +namespace AlgebraicAnalysis.SplitLatticePresentation + +noncomputable section + +variable {R : Type*} [CommRing R] [IsLocalRing R] +variable {ι : Type*} [Fintype ι] [DecidableEq ι] + +/-- A matrix presentation constructed from a direct summand, with no chosen +basis or retraction in the input. -/ +structure SplitMatrixPresentation + (L : Submodule R (ι → R)) (r : ℕ) where + /-- Column matrix for the inclusion of the summand. -/ + B : Matrix ι (Fin r) R + /-- Retraction matrix for the chosen summand coordinates. -/ + C : Matrix (Fin r) ι R + leftInverse : C * B = 1 + columnsSpan : + Submodule.span R (Set.range fun j => fun i => B i j) = L + +/-- A finite-rank complemented submodule of a finite coordinate module over a +local ring has split matrix coordinates. Finiteness descends along the +projection onto the summand, projectivity comes from the split inclusion, and +finite flat modules over local rings are free. -/ +theorem exists_splitMatrixPresentation + (L L' : Submodule R (ι → R)) (hcompl : IsCompl L L') (r : ℕ) + (hrank : Module.finrank R L = r) : + Nonempty (SplitMatrixPresentation L r) := by + let p : (ι → R) →ₗ[R] L := L.projectionOnto L' hcompl + let : Module.Finite R L := + Module.Finite.of_surjective p (Submodule.projectionOnto_surjective hcompl) + let : Module.Projective R L := + Module.Projective.of_split L.subtype p + (Submodule.projectionOnto_comp_subtype hcompl) + let : Module.Flat R L := Module.Flat.of_projective + let : Module.Free R L := Module.free_of_flat_of_isLocalRing + let b : Module.Basis (Fin r) R L := + Module.finBasisOfFinrankEq R L hrank + let e : Module.Basis ι R (ι → R) := Pi.basisFun R ι + let B : Matrix ι (Fin r) R := LinearMap.toMatrix b e L.subtype + let C : Matrix (Fin r) ι R := LinearMap.toMatrix e b p + refine ⟨{ + B := B + C := C + leftInverse := ?_ + columnsSpan := ?_ }⟩ + · have hmatrix := LinearMap.toMatrix_comp b e b p L.subtype + rw [Submodule.projectionOnto_comp_subtype hcompl, + LinearMap.toMatrix_id] at hmatrix + simpa [B, C] using hmatrix.symm + · have hcolumns : + (fun j : Fin r => fun i => B i j) = + fun j => (b j : ι → R) := by + funext j i + simp [B, e, LinearMap.toMatrix_apply, Pi.basisFun_repr] + rw [hcolumns] + have himage : + L.subtype '' Set.range b = + Set.range (fun j => (b j : ι → R)) := by + ext x + simp only [Set.mem_image, Set.mem_range, Submodule.coe_subtype, + exists_exists_eq_and] + rw [← himage, ← Submodule.map_span, b.span_eq, Submodule.map_top] + exact Submodule.range_subtype (p := L) + +/-- Property-valued form: no particular complement is part of the input. -/ +theorem exists_splitMatrixPresentation_of_isComplemented + (L : Submodule R (ι → R)) (hcompl : IsComplemented L) (r : ℕ) + (hrank : Module.finrank R L = r) : + Nonempty (SplitMatrixPresentation L r) := by + obtain ⟨L', hLL'⟩ := hcompl + exact exists_splitMatrixPresentation L L' hLL' r hrank + + +end +end AlgebraicAnalysis.SplitLatticePresentation diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/StableTorsionResidualSupport.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/StableTorsionResidualSupport.lean new file mode 100644 index 0000000000..030777a639 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/StableTorsionResidualSupport.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity +import Mathlib.RingTheory.Support + +/-! +# Support detects the residual after stable scalar torsion + +The support argument is most transparent before localization: the exact +sequence for the power kernel splits support into torsion and residual parts, +and `support_quotSMulTop` then applies at the larger prime. +-/ + +namespace AlgebraicAnalysis.StableTorsionResidualSupport + +open scoped Pointwise + +noncomputable section + +universe u v + +variable {R : Type u} {E : Type v} +variable [CommRing R] [AddCommGroup E] [Module R E] + +private abbrev scalarEnd (x : R) : E →ₗ[R] E := LinearMap.lsmul R E x + +@[nolint unusedArguments] +theorem residual_nontrivial_of_support + [IsNoetherianRing R] [Module.Finite R E] + (x : R) (n : ℕ) (p q : PrimeSpectrum R) + (hp : p ∈ Module.support R E) (hpq : p ≤ q) + (hxp : x ∉ p.asIdeal) + (hq : q ∈ Module.support R (QuotSMulTop x E)) : + Nontrivial (E ⧸ (LinearMap.ker (scalarEnd (E := E) x ^ n) ⊔ + (scalarEnd (E := E) x).range)) := by + let f := scalarEnd (E := E) x + let T : Submodule R E := LinearMap.ker (f ^ n) + have hpower : ∀ m (z : E), (f ^ m) z = x ^ m • z := by + intro m + induction m with + | zero => intro z; simp + | succ m ih => + intro z + simp [pow_succ, Module.End.mul_apply, ih, f, scalarEnd, smul_smul] + have hTann : x ^ n ∈ Module.annihilator R T := by + rw [Module.mem_annihilator] + intro z + have hz := z.property + apply Subtype.ext + change x ^ n • (z : E) = 0 + change (f ^ n) (z : E) = 0 at hz + exact (hpower n (z : E)).symm.trans hz + have hpT : p ∉ Module.support R T := by + intro h + have hle := Module.annihilator_le_of_mem_support h + have hpow : x ^ n ∈ p.asIdeal := hle hTann + exact hxp (p.isPrime.mem_of_pow_mem n hpow) + have hexact : Function.Exact T.subtype T.mkQ := + LinearMap.exact_subtype_mkQ T + have hsupport : Module.support R E = + Module.support R T ∪ Module.support R (E ⧸ T) := + Module.support_of_exact hexact T.subtype_injective T.mkQ_surjective + have hpquot : p ∈ Module.support R (E ⧸ T) := by + have hpmem : p ∈ Module.support R T ∪ Module.support R (E ⧸ T) := by + rw [← hsupport] + exact hp + exact hpmem.resolve_left hpT + have hqquot : q ∈ Module.support R (E ⧸ T) := + Module.mem_support_mono hpq hpquot + have hqzero : q ∈ PrimeSpectrum.zeroLocus ({x} : Set R) := by + rw [Module.support_quotSMulTop (M := E) x] at hq + exact hq.2 + have hqres : q ∈ Module.support R (QuotSMulTop x (E ⧸ T)) := by + rw [Module.support_quotSMulTop] + exact ⟨hqquot, hqzero⟩ + have hglobal : Nontrivial (QuotSMulTop x (E ⧸ T)) := + Module.nonempty_support_iff.mp ⟨q, hqres⟩ + have hmap : Submodule.map T.mkQ (f.range) = + x • (⊤ : Submodule R (E ⧸ T)) := by + ext z + constructor + · rintro ⟨y, ⟨w, rfl⟩, rfl⟩ + simpa [f, scalarEnd] using + (Submodule.smul_mem_pointwise_smul (T.mkQ w) x (⊤ : Submodule R (E ⧸ T)) trivial) + · intro hz + have hz' : z ∈ Ideal.span ({x} : Set R) • (⊤ : Submodule R (E ⧸ T)) := by + rw [Submodule.ideal_span_singleton_smul] + exact hz + refine Submodule.smul_induction_on hz' ?_ (fun a b ha hb ↦ add_mem ha hb) + intro r hr z hz + rcases (Ideal.mem_span_singleton.mp hr) with ⟨c, rfl⟩ + refine Submodule.Quotient.induction_on T z ?_ + intro w + refine ⟨f (c • w), ⟨c • w, rfl⟩, ?_⟩ + simp [f, scalarEnd, smul_smul, mul_comm] + have hequiv : + ((E ⧸ T) ⧸ Submodule.map T.mkQ f.range) ≃ₗ[R] + E ⧸ (T ⊔ f.range) := + Submodule.quotientQuotientEquivQuotientSup T f.range + have hnontriv : Nontrivial ((E ⧸ T) ⧸ Submodule.map T.mkQ f.range) := by + rw [hmap] + exact Submodule.Quotient.nontrivial_iff.mpr (by + intro htop + exact not_subsingleton_iff_nontrivial.mpr hglobal + (Submodule.Quotient.subsingleton_iff.mpr htop)) + let : Nontrivial ((E ⧸ T) ⧸ Submodule.map T.mkQ f.range) := hnontriv + have hfinal := Equiv.nontrivial hequiv.symm.toEquiv + simpa [T, f] using hfinal + + +end +end AlgebraicAnalysis.StableTorsionResidualSupport diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/StablyFree.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/StablyFree.lean new file mode 100644 index 0000000000..5db20dc612 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/StablyFree.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Finiteness.Projective + +/-! +# Stable freeness interface for projective modules + +This module records the application-independent right-module formulation of +stable freeness used in filtered-ring arguments. It is a definition, not a +claim that any particular ring has the property. +-/ + +namespace AlgebraicAnalysis +namespace StablyFree + +universe u + +/-- Every finitely generated projective right `R`-module becomes finite free +after adding a finite free summand. Right modules are represented as modules +over `Rᵐᵒᵖ`, so the order of scalar multiplication remains explicit. -/ +def StablyFreeProjectives (R : Type u) [Ring R] : Prop := + ∀ (P : Type u) [AddCommGroup P] [Module Rᵐᵒᵖ P], + Module.Projective Rᵐᵒᵖ P → Module.Finite Rᵐᵒᵖ P → + ∃ m n : ℕ, + Nonempty (P × (Fin m → Rᵐᵒᵖ) ≃ₗ[Rᵐᵒᵖ] (Fin n → Rᵐᵒᵖ)) + +end StablyFree +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/TorsionProjectiveImage.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TorsionProjectiveImage.lean new file mode 100644 index 0000000000..848f1ac157 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TorsionProjectiveImage.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FreeSummandInduction + +/-! +# A projective-image terminal module lemma + +This file isolates the unconditional linear-algebra step in a torsion +presentation: a surjection from a product which kills its free factor factors +through the first factor. It does not assert that a torsion module admits +such a presentation. +-/ + +namespace AlgebraicAnalysis.TorsionProjectiveImage + +variable {R P F T : Type*} [Ring R] +variable [AddCommGroup P] [Module R P] +variable [AddCommGroup F] [Module R F] +variable [AddCommGroup T] [Module R T] + +/-- A linear map out of a product which vanishes on the second factor is +already a map out of the first factor. -/ +theorem linearMap_product_factor_first + (q : P × F →ₗ[R] T) + (hkill : ∀ z : F, q (0, z) = 0) : + ∃ q₁ : P →ₗ[R] T, + q = q₁.comp (LinearMap.fst R P F) := by + let q₁ : P →ₗ[R] T := q.comp (LinearMap.inl R P F) + refine ⟨q₁, ?_⟩ + apply LinearMap.ext + rintro ⟨p, z⟩ + have hdecomp : (p, z) = (p, 0) + (0, z) := by + ext <;> simp + calc + q (p, z) = q ((p, 0) + (0, z)) := congrArg q hdecomp + _ = q (p, 0) + q (0, z) := q.map_add _ _ + _ = q (p, 0) := by rw [hkill, add_zero] + _ = q₁ p := rfl + _ = (q₁.comp (LinearMap.fst R P F)) (p, z) := rfl + +/-- Surjectivity also descends through the factorization in +`linearMap_product_factor_first`. -/ +theorem surjective_factor_first_of_surjective + (q : P × F →ₗ[R] T) + (hkill : ∀ z : F, q (0, z) = 0) + (hq : Function.Surjective q) : + ∃ q₁ : P →ₗ[R] T, Function.Surjective q₁ := by + obtain ⟨q₁, hfactor⟩ := linearMap_product_factor_first q hkill + refine ⟨q₁, ?_⟩ + intro t + obtain ⟨z, hz⟩ := hq t + refine ⟨z.1, ?_⟩ + rw [hfactor] at hz + simpa using hz + +/-- If a module `P` is identified with a projective left ideal times a free +factor, and a quotient map kills that free factor, then the target is a +homomorphic image of the projective left ideal. Here `I : Submodule R R` is +a left ideal of the ring. -/ +theorem projective_leftIdeal_image_of_terminal_split + (I : Submodule R R) [Module.Projective R I] + (e : P ≃ₗ[R] I × F) + (q : P →ₗ[R] T) (hq : Function.Surjective q) + (hkill : ∀ z : F, q (e.symm (0, z)) = 0) : + ∃ qI : I →ₗ[R] T, + Function.Surjective qI ∧ Module.Projective R I := by + let qprod : I × F →ₗ[R] T := q.comp e.symm.toLinearMap + have hqprod : Function.Surjective qprod := by + intro t + obtain ⟨p, hp⟩ := hq t + refine ⟨e p, ?_⟩ + simpa [qprod] using hp + have hkillprod : ∀ z : F, qprod (0, z) = 0 := by + intro z + exact hkill z + obtain ⟨qI, hqI⟩ := surjective_factor_first_of_surjective qprod hkillprod hqprod + exact ⟨qI, hqI, inferInstance⟩ + + +end AlgebraicAnalysis.TorsionProjectiveImage diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/TriangularDenominator.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TriangularDenominator.lean new file mode 100644 index 0000000000..4b358e1073 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TriangularDenominator.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightIntersection + +/-! +# Generic finite triangular denominator arguments + +This file records the purely module-theoretic part of the triangular +denominator argument. The coefficients act on the right, represented by +scalars in `Rᵐᵒᵖ`; in particular `(op s) • m` means `m * s`. + +There are two useful forms. First, a finite family of torsion generators has +one common nonzero denominator, obtained from the finite intersection of their +right annihilator ideals. Second, explicit denominator clearance through a +finite filtration composes to denominator clearance for the whole quotient. +The hypotheses describing the filtration are data, rather than an assertion +that an arbitrary Ore extension is free or flat. +-/ + +namespace AlgebraicAnalysis +namespace TriangularDenominator + +open MulOpposite +open AlgebraicAnalysis.OreRightIntersection + +universe u v + +section FiniteGenerators + +variable {R : Type u} [Ring R] [IsDomain R] +variable {M : Type v} [AddCommGroup M] [Module Rᵐᵒᵖ M] + +/-- The right-action map associated to a vector. -/ +def rightActionLinear (m : M) : R →ₗ[Rᵐᵒᵖ] M where + toFun s := (op s) • m + map_add' s t := by + simp [add_smul] + map_smul' a s := by + change (op (s * unop a)) • m = a • ((op s) • m) + rw [op_mul, smul_smul] + rfl + +/-- The right annihilator of a vector, represented as a right ideal. -/ +def rightAnnihilator (m : M) : Submodule Rᵐᵒᵖ R := + LinearMap.ker (rightActionLinear m) + +/-- A finite family of torsion vectors admits one common nonzero denominator. -/ +theorem finite_vectors_common_annihilator + {n : ℕ} (g : Fin n → M) + (hAnn : ∀ i, ∃ s : R, s ≠ 0 ∧ (op s) • g i = 0) + (hOre : RightOreCondition R) : + ∃ s : R, s ≠ 0 ∧ ∀ i, (op s) • g i = 0 := by + classical + let I : Fin n → Submodule Rᵐᵒᵖ R := fun i => rightAnnihilator (g i) + have hI : ∀ i ∈ (Finset.univ : Finset (Fin n)), + ∃ x ∈ I i, x ≠ 0 := by + intro i hi + rcases hAnn i with ⟨s, hs, hsg⟩ + refine ⟨s, ?_, hs⟩ + apply LinearMap.mem_ker.mpr + exact hsg + obtain ⟨s, hs, hsI⟩ := + exists_mem_finset_rightIdeals (R := R) (Finset.univ : Finset (Fin n)) I hI hOre + refine ⟨s, hs, ?_⟩ + intro i + exact LinearMap.mem_ker.mp (hsI i (Finset.mem_univ i)) + +end FiniteGenerators + +section Filtration + +variable {R : Type u} [Ring R] [IsDomain R] +variable {M : Type v} [AddCommGroup M] [Module Rᵐᵒᵖ M] + +/-- One explicit denominator-clearing step of a filtration. -/ +def StepClearance (F : ℕ → Submodule Rᵐᵒᵖ M) (i : ℕ) : Prop := + ∀ m : M, m ∈ F (i + 1) → + ∃ s : R, s ≠ 0 ∧ (op s) • m ∈ F i + +/-- Iterating finitely many explicit triangular steps clears a denominator. -/ +theorem filtration_clearance + (F : ℕ → Submodule Rᵐᵒᵖ M) (n : ℕ) + (hstep : ∀ i < n, StepClearance F i) {m : M} (hm : m ∈ F n) : + ∃ s : R, s ≠ 0 ∧ (op s) • m ∈ F 0 := by + induction n generalizing m with + | zero => + refine ⟨1, one_ne_zero, ?_⟩ + simpa using hm + | succ n ih => + rcases hstep n (Nat.lt_succ_self n) m hm with ⟨s, hs, hsm⟩ + have hstep' : ∀ i < n, StepClearance F i := by + intro i hi + exact hstep i (by omega) + rcases ih hstep' hsm with ⟨t, ht, htm⟩ + refine ⟨s * t, mul_ne_zero hs ht, ?_⟩ + change (op (s * t)) • m ∈ F 0 + simpa only [op_mul, smul_smul] using htm + +/-- A finite cleared filtration makes the terminal quotient torsion. -/ +def IsTorsionRight (N : Submodule Rᵐᵒᵖ M) : Prop := + ∀ z : M ⧸ N, ∃ s : R, s ≠ 0 ∧ (op s) • z = 0 + +theorem filtration_quotient_isTorsion + (F : ℕ → Submodule Rᵐᵒᵖ M) (n : ℕ) + (hstep : ∀ i < n, StepClearance F i) + (htop : F n = ⊤) : + IsTorsionRight (R := R) (M := M) (F 0) := by + intro z + refine Submodule.Quotient.induction_on (F 0) z ?_ + intro m + have hm : m ∈ F n := by + rw [htop] + trivial + rcases filtration_clearance F n hstep hm with ⟨s, hs, hsm⟩ + refine ⟨s, hs, ?_⟩ + change (F 0).mkQ ((op s) • m) = 0 + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact hsm + +end Filtration + + +end TriangularDenominator +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoSimplicity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoSimplicity.lean new file mode 100644 index 0000000000..0b5231ee9d --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoSimplicity.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Abstract two-simplicity transfer + +This file records the ring-theoretic transfer from a principal-right-quotient +torsion statement to two-simplicity. It does not assert the localization or +rank theorem needed to produce that torsion statement. +-/ + +namespace AlgebraicAnalysis.TwoSimplicity + +variable {Λ Γ : Type*} [Ring Λ] [Ring Γ] + +/-- The two-sided coefficient identity used for two-simplicity. -/ +def TwoSimple (R : Type*) [Ring R] : Prop := + ∀ d₁ d₂ : R, d₁ ≠ 0 → d₂ ≠ 0 → + ∃ f g u v : R, f * d₁ * u + g * d₂ * v = 1 + +/-- Finite, torsion-free bimodule extension data with written orders visible. -/ +structure FiniteTorsionFreeExtension (ι : Λ →+* Γ) : Prop where + injective : Function.Injective ι + rightFinite : ∃ n : ℕ, ∃ basis : Fin n → Γ, + ∀ x : Γ, ∃ a : Fin n → Λ, x = ∑ i, basis i * ι (a i) + leftFinite : ∃ n : ℕ, ∃ basis : Fin n → Γ, + ∀ x : Γ, ∃ a : Fin n → Λ, x = ∑ i, ι (a i) * basis i + rightTorsionFree : ∀ a : Λ, a ≠ 0 → ∀ x : Γ, x * ι a = 0 → x = 0 + leftTorsionFree : ∀ a : Λ, a ≠ 0 → ∀ x : Γ, ι a * x = 0 → x = 0 + +/-- The exact class-of-`1` torsion statement needed by the transfer. -/ +def PrincipalRightQuotientTorsion (ι : Λ →+* Γ) : Prop := + ∀ d : Γ, d ≠ 0 → + ∃ a : Λ, a ≠ 0 ∧ ∃ w : Γ, ι a = d * w + +/-- +Two-simplicity transfers along a ring map once the principal right-quotient +torsion condition is supplied. Producing that condition is a separate +localization/rank theorem. +-/ +theorem twoSimple_of_principalRightQuotientTorsion + (ι : Λ →+* Γ) + (hΛ : TwoSimple Λ) + (hquot : PrincipalRightQuotientTorsion ι) : + TwoSimple Γ := by + intro d₁ d₂ hd₁ hd₂ + obtain ⟨a₁, ha₁, w₁, hw₁⟩ := hquot d₁ hd₁ + obtain ⟨a₂, ha₂, w₂, hw₂⟩ := hquot d₂ hd₂ + obtain ⟨f, g, u, v, huv⟩ := hΛ a₁ a₂ ha₁ ha₂ + refine ⟨ι f, ι g, w₁ * ι u, w₂ * ι v, ?_⟩ + have h := congrArg ι huv + simpa only [map_add, map_mul, map_one, hw₁, hw₂, mul_assoc] using h + + +end AlgebraicAnalysis.TwoSimplicity diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoTermPageLength.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoTermPageLength.lean new file mode 100644 index 0000000000..41276f67b5 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/TwoTermPageLength.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Length +import Mathlib.LinearAlgebra.Isomorphisms +import Mathlib.Tactic + +namespace AlgebraicAnalysis.TwoTermPageLength + +open scoped ENat + +theorem exists_boundary_eq_top_of_iSup_eq_top + {R M : Type*} [Semiring R] [AddCommMonoid M] [Module R M] + [IsNoetherian R M] (D : ℕ →o Submodule R M) (hD : ⨆ r, D r = ⊤) : + ∃ N, D N = ⊤ := by + obtain ⟨N, hN⟩ := (IsNoetherian.noetherian (⊤ : Submodule R M)).stabilizes_of_iSup_eq D hD + exact ⟨N, hN.symm⟩ + +theorem twoTermPage_length_target_le_source + {R : Type*} [Ring R] + (A C : ℕ → Type*) + [∀ r, AddCommGroup (A r)] [∀ r, Module R (A r)] + [∀ r, AddCommGroup (C r)] [∀ r, Module R (C r)] + (hA0 : IsFiniteLength R (A 0)) + (hC0 : IsFiniteLength R (C 0)) + (d : ∀ r, A r →ₗ[R] C r) + (sourceSucc : ∀ r, A (r + 1) ≃ₗ[R] LinearMap.ker (d r)) + (targetSucc : ∀ r, C (r + 1) ≃ₗ[R] C r ⧸ LinearMap.range (d r)) + (N : ℕ) [Subsingleton (C N)] : + Module.length R (C 0) ≤ Module.length R (A 0) := by + have hA : ∀ r, IsFiniteLength R (A r) := by + intro r + induction r with + | zero => exact hA0 + | succ r ihr => + apply (sourceSucc r).symm.isFiniteLength + exact IsFiniteLength.of_injective ihr (Submodule.subtype_injective _) + have hC : ∀ r, IsFiniteLength R (C r) := by + intro r + induction r with + | zero => exact hC0 + | succ r ihr => + apply (targetSucc r).symm.isFiniteLength + exact IsFiniteLength.of_surjective ihr (Submodule.mkQ_surjective _) + let : ∀ r, IsNoetherian R (A r) := fun r => + (isFiniteLength_iff_isNoetherian_isArtinian.mp (hA r)).1 + let : ∀ r, IsArtinian R (A r) := fun r => + (isFiniteLength_iff_isNoetherian_isArtinian.mp (hA r)).2 + let : ∀ r, IsNoetherian R (C r) := fun r => + (isFiniteLength_iff_isNoetherian_isArtinian.mp (hC r)).1 + let : ∀ r, IsArtinian R (C r) := fun r => + (isFiniteLength_iff_isNoetherian_isArtinian.mp (hC r)).2 + have source_length (r : ℕ) : + Module.length R (A r) = + Module.length R (A (r + 1)) + Module.length R (LinearMap.range (d r)) := by + rw [(sourceSucc r).length_eq] + exact Module.length_eq_add_of_exact + (LinearMap.ker (d r)).subtype (d r).rangeRestrict + (Submodule.subtype_injective _) + (LinearMap.range_eq_top.mp (LinearMap.range_rangeRestrict (d r))) + (by + rw [LinearMap.exact_iff, Submodule.range_subtype, LinearMap.ker_rangeRestrict]) + have target_length (r : ℕ) : + Module.length R (C r) = + Module.length R (LinearMap.range (d r)) + Module.length R (C (r + 1)) := by + rw [(targetSucc r).length_eq] + exact Module.length_eq_add_of_exact + (LinearMap.range (d r)).subtype (LinearMap.range (d r)).mkQ + (Submodule.subtype_injective _) (Submodule.mkQ_surjective _) + (LinearMap.exact_subtype_mkQ _) + have source_ne_top (r : ℕ) : Module.length R (A r) ≠ ⊤ := Module.length_ne_top + have target_ne_top (r : ℕ) : Module.length R (C r) ≠ ⊤ := Module.length_ne_top + have range_ne_top (r : ℕ) : Module.length R (LinearMap.range (d r)) ≠ ⊤ := by + exact Module.length_ne_top + have invariant : ∀ n, + ENat.toNat (Module.length R (C 0)) + ENat.toNat (Module.length R (A n)) = + ENat.toNat (Module.length R (A 0)) + ENat.toNat (Module.length R (C n)) := by + intro n + induction n with + | zero => simp [add_comm] + | succ n ih => + have hs := congrArg ENat.toNat (source_length n) + have ht := congrArg ENat.toNat (target_length n) + rw [ENat.toNat_add (source_ne_top (n + 1)) (range_ne_top n)] at hs + rw [ENat.toNat_add (range_ne_top n) (target_ne_top (n + 1))] at ht + omega + have h := invariant N + have hCN : ENat.toNat (Module.length R (C N)) = 0 := by simp + rw [hCN, add_zero] at h + have hnat : ENat.toNat (Module.length R (C 0)) ≤ + ENat.toNat (Module.length R (A 0)) := by omega + rw [← ENat.natCast_toNat (target_ne_top 0), ← ENat.natCast_toNat (source_ne_top 0)] + exact_mod_cast hnat + + +end AlgebraicAnalysis.TwoTermPageLength diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/UniformBoundaryVanishing.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/UniformBoundaryVanishing.lean new file mode 100644 index 0000000000..c4fb8b61e4 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/UniformBoundaryVanishing.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Module.LocalizedModule.Basic +import Mathlib.RingTheory.Localization.Module +import Mathlib.RingTheory.Noetherian.Filter + +/-! +# Uniform vanishing of an ascending family of boundary maps + +Pointwise eventual vanishing becomes uniform on a Noetherian source. The +localized statement deliberately assumes Noetherianity only after +localization. +-/ + +open IsNoetherian + +namespace AlgebraicAnalysis + +theorem exists_uniform_zero_of_noetherian + {R U : Type*} [Semiring R] [AddCommMonoid U] [Module R U] + {V : ℕ → Type*} [∀ r, AddCommMonoid (V r)] [∀ r, Module R (V r)] + (b : ∀ r, U →ₗ[R] V r) + (hmono : ∀ r s, r ≤ s → LinearMap.ker (b r) ≤ LinearMap.ker (b s)) + (hpoint : ∀ u, ∃ r, b r u = 0) [IsNoetherian R U] : + ∃ r, b r = 0 := by + let F : ℕ →o Submodule R U := + { toFun := fun r => LinearMap.ker (b r) + monotone' := fun r s hrs => hmono r s hrs } + obtain ⟨n, hn⟩ := monotone_stabilizes_iff_noetherian.mpr inferInstance F + refine ⟨n, LinearMap.ext fun u => ?_⟩ + obtain ⟨r, hr⟩ := hpoint u + have hu : u ∈ F r := LinearMap.mem_ker.mpr hr + have hu' : u ∈ F (max n r) := + (hmono r (max n r) (Nat.le_max_right _ _)) hu + have heq : F n = F (max n r) := hn _ (Nat.le_max_left _ _) + have : u ∈ F n := heq.symm ▸ hu' + exact LinearMap.mem_ker.mp this + +theorem exists_uniform_subsingleton_of_noetherian + {R U : Type*} [Semiring R] [AddCommMonoid U] [Module R U] + {V : ℕ → Type*} [∀ r, AddCommMonoid (V r)] [∀ r, Module R (V r)] + (b : ∀ r, U →ₗ[R] V r) + (hmono : ∀ r s, r ≤ s → LinearMap.ker (b r) ≤ LinearMap.ker (b s)) + (hpoint : ∀ u, ∃ r, b r u = 0) + (hsurj : ∀ r, Function.Surjective (b r)) [IsNoetherian R U] : + ∃ r, Subsingleton (V r) := by + obtain ⟨r, hr⟩ := exists_uniform_zero_of_noetherian b hmono hpoint + refine ⟨r, ?_⟩ + constructor + intro x y + obtain ⟨u, rfl⟩ := hsurj r x + obtain ⟨v, rfl⟩ := hsurj r y + simp [hr] + +section Localized + +variable {R : Type*} [CommRing R] (S : Submonoid R) +variable {U : Type*} [AddCommMonoid U] [Module R U] +variable {V : ℕ → Type*} [∀ r, AddCommMonoid (V r)] [∀ r, Module R (V r)] + +private theorem localized_ker_mono + (b : ∀ r, U →ₗ[R] V r) + (hmono : ∀ r s, r ≤ s → LinearMap.ker (b r) ≤ LinearMap.ker (b s)) + {r s : ℕ} (hrs : r ≤ s) : + LinearMap.ker (LocalizedModule.map S (b r)) ≤ + LinearMap.ker (LocalizedModule.map S (b s)) := by + intro z hz + induction z using LocalizedModule.induction_on with + | _ u t => + have hz' := LinearMap.mem_ker.mp hz + rw [LocalizedModule.map_mk] at hz' + change LocalizedModule.mk (b r u) t = 0 at hz' + apply LinearMap.mem_ker.mpr + rw [LocalizedModule.map_mk] + change LocalizedModule.mk (b s u) t = 0 + rw [IsLocalizedModule.mk_eq_mk' (S := S)] at hz' ⊢ + rw [IsLocalizedModule.mk'_eq_zero' (LocalizedModule.mkLinearMap S (V r))] at hz' + obtain ⟨a, ha⟩ := hz' + have hscaled : b r (a • u) = 0 := by + simpa [map_smul] using ha + have hscaled' : b s (a • u) = 0 := + LinearMap.mem_ker.mp (hmono r s hrs (LinearMap.mem_ker.mpr hscaled)) + rw [IsLocalizedModule.mk'_eq_zero'] + exact ⟨a, by simpa [map_smul] using hscaled'⟩ + +theorem exists_uniform_zero_localized + (b : ∀ r, U →ₗ[R] V r) + (hmono : ∀ r s, r ≤ s → LinearMap.ker (b r) ≤ LinearMap.ker (b s)) + (hpoint : ∀ u, ∃ r, b r u = 0) + [IsNoetherian (Localization S) (LocalizedModule S U)] : + ∃ r, LocalizedModule.map S (b r) = 0 := by + let B : ∀ r, LocalizedModule S U →ₗ[Localization S] + LocalizedModule S (V r) := fun r => LocalizedModule.map S (b r) + have hpoint' : ∀ u, ∃ r, B r u = 0 := by + intro u + induction u using LocalizedModule.induction_on with + | _ m s => + obtain ⟨r, hr⟩ := hpoint m + refine ⟨r, ?_⟩ + simp [B, LocalizedModule.map_mk, hr] + obtain ⟨r, hr⟩ := exists_uniform_zero_of_noetherian B + (fun r s hrs => by simpa only [B] using localized_ker_mono S b hmono hrs) hpoint' + exact ⟨r, by simpa [B] using hr⟩ + +theorem exists_uniform_subsingleton_localized + (b : ∀ r, U →ₗ[R] V r) + (hmono : ∀ r s, r ≤ s → LinearMap.ker (b r) ≤ LinearMap.ker (b s)) + (hpoint : ∀ u, ∃ r, b r u = 0) + (hsurj : ∀ r, Function.Surjective (b r)) + [IsNoetherian (Localization S) (LocalizedModule S U)] : + ∃ r, Subsingleton (LocalizedModule S (V r)) := by + let B : ∀ r, LocalizedModule S U →ₗ[Localization S] + LocalizedModule S (V r) := fun r => LocalizedModule.map S (b r) + have hsurj' : ∀ r, Function.Surjective (B r) := by + intro r + exact LocalizedModule.map_surjective S (b r) (hsurj r) + exact exists_uniform_subsingleton_of_noetherian B + (fun r s hrs => by simpa [B] using localized_ker_mono S b hmono hrs) (by + intro u + induction u using LocalizedModule.induction_on with + | _ m s => + obtain ⟨r, hr⟩ := hpoint m + refine ⟨r, ?_⟩ + simp [B, LocalizedModule.map_mk, hr]) hsurj' + +end Localized + + +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Module/Unimodular.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Module/Unimodular.lean new file mode 100644 index 0000000000..cebca8b35d --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Module/Unimodular.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Unimodular elements and a free rank-one summand + +This file contains the unconditional module-theoretic splitting associated +to a unimodular element. It uses no rank, Ore, simplicity, or finiteness +hypothesis. +-/ + +namespace AlgebraicAnalysis.Unimodular + +variable {R N : Type*} [Ring R] [AddCommGroup N] [Module R N] + +/-- An element of a left module is unimodular if a left-linear functional + takes it to `1`. -/ +def IsUnimodular (x : N) : Prop := ∃ φ : N →ₗ[R] R, φ x = 1 + +theorem exists_unimodular_iff_surjective : + (∃ x : N, IsUnimodular (R := R) x) ↔ + ∃ φ : N →ₗ[R] R, Function.Surjective φ := by + constructor + · rintro ⟨x, φ, hφ⟩ + exact ⟨φ, fun r ↦ by + refine ⟨r • x, ?_⟩ + rw [φ.map_smul, hφ, smul_eq_mul, mul_one] + ⟩ + · rintro ⟨φ, hφ⟩ + obtain ⟨x', hx'⟩ := hφ 1 + exact ⟨x', φ, hx'⟩ + +/-- The projection onto the kernel of a functional which is normalized at + `x`. -/ +def unimodularKernelProjection (φ : N →ₗ[R] R) (x : N) + (hx : φ x = 1) : N →ₗ[R] LinearMap.ker φ := + (LinearMap.id - (LinearMap.toSpanSingleton R N x).comp φ).codRestrict + (LinearMap.ker φ) (by + intro y + rw [LinearMap.mem_ker] + simp only [LinearMap.sub_apply, LinearMap.id_apply, LinearMap.coe_comp, + Function.comp_apply, LinearMap.toSpanSingleton_apply] + rw [φ.map_sub, φ.map_smul, hx, smul_eq_mul, mul_one, sub_self]) + +/-- The canonical splitting map associated to a normalized functional. -/ +def unimodularSplitMap (φ : N →ₗ[R] R) (x : N) (hx : φ x = 1) : + N →ₗ[R] LinearMap.ker φ × R := + (unimodularKernelProjection φ x hx).prod φ + +/-- The inverse map to `unimodularSplitMap`. -/ +def unimodularSplitMapInv (φ : N →ₗ[R] R) (x : N) : + LinearMap.ker φ × R →ₗ[R] N := + { toFun := fun y ↦ y.1.1 + y.2 • x + map_add' := by + intro y z + simp only [Prod.fst_add, Prod.snd_add, Submodule.coe_add, add_smul] + abel + map_smul' := by + rintro r ⟨y, s⟩ + dsimp + rw [smul_add, mul_smul] + } + +theorem unimodularSplitMap_left_inverse + (φ : N →ₗ[R] R) (x : N) (hx : φ x = 1) : + (unimodularSplitMapInv φ x).comp (unimodularSplitMap φ x hx) = + LinearMap.id := by + apply LinearMap.ext + intro y + dsimp [unimodularSplitMap, unimodularSplitMapInv, + unimodularKernelProjection] + change (y - φ y • x) + φ y • x = y + exact sub_add_cancel _ _ + +theorem unimodularSplitMap_right_inverse + (φ : N →ₗ[R] R) (x : N) (hx : φ x = 1) : + (unimodularSplitMap φ x hx).comp (unimodularSplitMapInv φ x) = + LinearMap.id := by + apply LinearMap.ext + rintro ⟨y, r⟩ + dsimp [unimodularSplitMap, unimodularSplitMapInv, + unimodularKernelProjection] + apply Prod.ext + · apply Subtype.ext + change y.1 + r • x - φ (y.1 + r • x) • x = y.1 + rw [φ.map_add, φ.map_smul, LinearMap.mem_ker.mp y.2] + simp [hx, smul_eq_mul] + · simp only [LinearMap.comp_apply, unimodularSplitMap, LinearMap.prod_apply, + unimodularSplitMapInv] + change φ (y.1 + r • x) = r + rw [φ.map_add, φ.map_smul, LinearMap.mem_ker.mp y.2, hx] + simp [smul_eq_mul] + +/-- A unimodular element splits off a free rank-one factor. -/ +def unimodularSplitEquiv (φ : N →ₗ[R] R) (x : N) (hx : φ x = 1) : + N ≃ₗ[R] LinearMap.ker φ × R := + LinearEquiv.ofLinear (unimodularSplitMap φ x hx) + (unimodularSplitMapInv φ x) + (unimodularSplitMap_right_inverse φ x hx) + (unimodularSplitMap_left_inverse φ x hx) + +theorem unimodular_split (x : N) (hx : IsUnimodular (R := R) x) : + ∃ φ : N →ₗ[R] R, ∃ _hφ : φ x = 1, + Nonempty (N ≃ₗ[R] LinearMap.ker φ × R) := by + obtain ⟨φ, hφ⟩ := hx + exact ⟨φ, hφ, ⟨unimodularSplitEquiv φ x hφ⟩⟩ + +/-- The cyclic submodule generated by a unimodular element is a free + rank-one module. The target is the actual range, so no commutativity or + centrality assumption on `R` is hidden in the statement. -/ +theorem unimodular_span_singleton_free (x : N) + (hx : IsUnimodular (R := R) x) : + Module.Free R (LinearMap.range (LinearMap.toSpanSingleton R N x)) := by + obtain ⟨φ, hφ⟩ := hx + let e : R ≃ₗ[R] LinearMap.range (LinearMap.toSpanSingleton R N x) := + LinearEquiv.ofInjective (LinearMap.toSpanSingleton R N x) (by + intro r s hrs + change r • x = s • x at hrs + have hzero : (r - s) • x = 0 := by + rw [sub_smul, hrs, sub_self] + have hzero' := congrArg φ hzero + have hrs' : r - s = 0 := by + simpa [φ.map_smul, hφ, smul_eq_mul] using hzero' + exact sub_eq_zero.mp hrs') + exact Module.Free.of_equiv e + +/-- The kernel of a split functional is a direct summand of its domain. In + particular, if the domain is projective then this kernel is projective. -/ +theorem projective_ker_of_unimodular + [Module.Projective R N] (φ : N →ₗ[R] R) (x : N) (hx : φ x = 1) : + Module.Projective R (LinearMap.ker φ) := by + apply Module.Projective.of_split (LinearMap.ker φ).subtype + (unimodularKernelProjection φ x hx) + apply LinearMap.ext + intro y + apply Subtype.ext + dsimp [unimodularKernelProjection] + change y.1 - φ y.1 • x = y.1 + rw [LinearMap.mem_ker.mp y.2, zero_smul, sub_zero] + + +end AlgebraicAnalysis.Unimodular diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/ActiveCoordinate.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/ActiveCoordinate.lean new file mode 100644 index 0000000000..072329aee2 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/ActiveCoordinate.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity + +/-! +# Active-coordinate decomposition in a derivation Ore extension + +This file isolates a reusable algebraic interface for one distinguished +coefficient coordinate. The coefficient ring may be noncommutative; the +coordinate is required to be central in that ring, while the active derivation +annihilates ground scalars and sends the coordinate to `1`. + +The results use only the checked normal-form construction. They do not +postulate a PBW basis, a presented Weyl algebra, or an operator realization. +-/ + +namespace AlgebraicAnalysis.OreActiveCoordinate + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + + +/-! ## The source-relative active-coordinate data -/ + +/-- Hypotheses for one active differential-Ore coordinate. + +The coefficient ring can be noncommutative. `coordinate_central` is the exact +hypothesis needed for coefficients of an active-variable expansion to commute +with polynomials in the coordinate. The two derivation hypotheses record that +the active derivation fixes ground scalars and differentiates the coordinate. +-/ +structure ActiveCoordinateData (k C : Type*) [CommRing k] [Ring C] + [Algebra k C] where + /-- The coefficient derivation defining the Ore relation. -/ + derivation : OreDivisionDerivation C + /-- The distinguished central coefficient coordinate. -/ + coordinate : C + coordinate_central : ∀ c : C, Commute coordinate c + derivation_smul : ∀ a : k, derivation (algebraMap k C a) = 0 + derivation_coordinate : derivation coordinate = algebraMap k C 1 + +namespace ActiveCoordinateData + +variable {k C : Type*} [CommRing k] [Ring C] [Algebra k C] +variable (A : ActiveCoordinateData k C) + +/-- The active one-variable derivation Ore ring. -/ +abbrev Ore := NormalOre A.derivation + +/-- The coefficient embedding into the active Ore ring. -/ +def coefficient (c : C) : A.Ore := normalCoefficient A.derivation c + +/-- The active Ore variable. -/ +def activeVariable : A.Ore := normalVariable A.derivation + +/-- The central-coordinate polynomial algebra inside the active Ore ring. -/ +def coordinatePolynomial (p : Polynomial k) : A.Ore := + p.eval₂ ((normalCoefficient A.derivation).comp (algebraMap k C)) + (coefficient A A.coordinate) + +/-- The defining differential-Ore relation at the distinguished coordinate. -/ +theorem variable_mul_coordinate : + activeVariable A * coefficient A A.coordinate = + coefficient A A.coordinate * activeVariable A + + coefficient A (algebraMap k C 1) := by + unfold activeVariable coefficient + rw [normalVariable_mul_coefficient] + rw [A.derivation_coordinate] + +/-- Ground scalars commute with the active Ore variable. -/ +theorem variable_mul_smul (a : k) : + activeVariable A * coefficient A (algebraMap k C a) = + coefficient A (algebraMap k C a) * activeVariable A := by + unfold activeVariable coefficient + rw [normalVariable_mul_coefficient, A.derivation_smul, map_zero] + simp + +/-- Every coefficient commutes with the image of a ground scalar. -/ +theorem coefficient_commute_smul (c : C) (a : k) : + Commute (coefficient A c) (coefficient A (algebraMap k C a)) := by + unfold coefficient + rw [commute_iff_eq] + rw [← (normalCoefficient A.derivation).map_mul, + ← (normalCoefficient A.derivation).map_mul] + rw [Algebra.commutes] + +/-- Every coefficient commutes with the distinguished coordinate. -/ +theorem coefficient_commute_coordinate (c : C) : + Commute (coefficient A c) (coefficient A A.coordinate) := by + unfold coefficient + rw [commute_iff_eq] + rw [← (normalCoefficient A.derivation).map_mul, + ← (normalCoefficient A.derivation).map_mul] + rw [A.coordinate_central c |>.symm.eq] + +/-- Every coefficient commutes with every polynomial in the central coordinate. -/ +theorem coefficient_commute_coordinatePolynomial (c : C) + (p : Polynomial k) : + Commute (coefficient A c) (coordinatePolynomial A p) := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [coordinatePolynomial, eval₂_add] + exact hp.add_right hq + | monomial n a => + rw [coordinatePolynomial, eval₂_monomial] + exact (coefficient_commute_smul A c a).mul_right + ((coefficient_commute_coordinate A c).pow_right n) + +/-- The coefficient-left normal form is an explicit finite active-variable +expansion. -/ +theorem normalForm_eq_support_sum (p : Polynomial C) : + normalForm A.derivation p = + ∑ j ∈ p.support, + coefficient A (p.coeff j) * activeVariable A ^ j := by + calc + normalForm A.derivation p = + normalForm A.derivation (∑ j ∈ p.support, + Polynomial.monomial j (p.coeff j)) := by + exact congrArg (normalForm A.derivation) p.as_sum_support + _ = ∑ j ∈ p.support, + normalForm A.derivation (Polynomial.monomial j (p.coeff j)) := by + change normalFormAddHom A.derivation + (∑ j ∈ p.support, Polynomial.monomial j (p.coeff j)) = _ + rw [map_sum] + rfl + _ = ∑ j ∈ p.support, + coefficient A (p.coeff j) * activeVariable A ^ j := by + simp only [normalForm_monomial] + rfl + +/-- Recombination using only coefficient/coordinate commutation; the active +Ore variable remains on the right throughout. -/ +theorem recombine_coordinate_polynomial (p : Polynomial C) + (b : A.Ore) (q : Polynomial k) : + (∑ j ∈ p.support, + (b * coefficient A (p.coeff j)) * + (coordinatePolynomial A q * activeVariable A ^ j)) = + b * coordinatePolynomial A q * normalForm A.derivation p := by + calc + (∑ j ∈ p.support, + (b * coefficient A (p.coeff j)) * + (coordinatePolynomial A q * activeVariable A ^ j)) = + ∑ j ∈ p.support, + b * coordinatePolynomial A q * + (coefficient A (p.coeff j) * activeVariable A ^ j) := by + apply Finset.sum_congr rfl + intro j hj + calc + (b * coefficient A (p.coeff j)) * + (coordinatePolynomial A q * activeVariable A ^ j) = + b * (coefficient A (p.coeff j) * + coordinatePolynomial A q) * activeVariable A ^ j := by + simp only [mul_assoc] + _ = b * (coordinatePolynomial A q * coefficient A (p.coeff j)) * + activeVariable A ^ j := by + rw [(coefficient_commute_coordinatePolynomial A + (p.coeff j) q).eq] + _ = b * coordinatePolynomial A q * + (coefficient A (p.coeff j) * activeVariable A ^ j) := by + simp only [mul_assoc] + _ = b * coordinatePolynomial A q * + (∑ j ∈ p.support, + coefficient A (p.coeff j) * activeVariable A ^ j) := by + symm + rw [Finset.mul_sum] + _ = b * coordinatePolynomial A q * normalForm A.derivation p := by + rw [normalForm_eq_support_sum] + +/-- Normal-form surjectivity supplies a finite active-variable expansion and +the coefficient commutations needed to use it source-relatively. -/ +theorem exists_active_expansion (d : A.Ore) : + ∃ p : Polynomial C, + d = ∑ j ∈ p.support, + coefficient A (p.coeff j) * activeVariable A ^ j ∧ + ∀ n : ℕ, ∀ q : Polynomial k, + Commute (coefficient A (p.coeff n)) + (coordinatePolynomial A q) := by + obtain ⟨p, hp⟩ := normalForm_surjective A.derivation d + refine ⟨p, ?_, ?_⟩ + · rw [← hp, normalForm_eq_support_sum] + · intro n q + exact coefficient_commute_coordinatePolynomial A (p.coeff n) q + +end ActiveCoordinateData + + +end +end AlgebraicAnalysis.OreActiveCoordinate diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Associativity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Associativity.lean new file mode 100644 index 0000000000..5799a6d09c --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Associativity.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightDivision + +/-! +# Associativity of derivation Ore normal forms over a noncommutative ring + +This removes the commutativity assumption from the faithful-operator proof of +associativity for `Stafford.OreDivision.rightMul`. +-/ + +namespace AlgebraicAnalysis.OreAssociativity + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision + +noncomputable section + +variable {B : Type*} [Ring B] + +lemma derivation_one (D : OreDivisionDerivation B) : D 1 = 0 := by + have h := D.leibniz 1 1 + simp only [one_mul, mul_one] at h + symm + calc + 0 = D 1 - D 1 := (sub_self _).symm + _ = (D 1 + D 1) - D 1 := by rw [← h] + _ = D 1 := by abel + +/-- Apply the coefficient derivation to every coefficient. -/ +def coefficientDerivation (D : OreDivisionDerivation B) : + Polynomial B →+ Polynomial B where + toFun p := p.sum fun i b => monomial i (D b) + map_zero' := by simp [Polynomial.sum_def] + map_add' p q := by + change (p + q).sum (fun i b => monomial i (D b)) = + p.sum (fun i b => monomial i (D b)) + + q.sum (fun i b => monomial i (D b)) + apply Polynomial.sum_add_index + · intro i + simp [D.map_zero] + · intro i a b + simp [D.map_add] + +@[simp] lemma coefficientDerivation_monomial + (D : OreDivisionDerivation B) (i : ℕ) (b : B) : + coefficientDerivation D (monomial i b) = monomial i (D b) := by + by_cases hb : b = 0 + · subst b + simp [D.map_zero] + · simp [coefficientDerivation, hb, D.map_zero] + +@[simp] lemma coefficientDerivation_C_mul + (D : OreDivisionDerivation B) (b : B) (p : Polynomial B) : + coefficientDerivation D (C b * p) = + C b * coefficientDerivation D p + C (D b) * p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + simp [map_add, hp, hq, mul_add, add_mul, add_assoc, add_left_comm, + add_comm] + | monomial n a => + simp [D.leibniz, mul_add, add_mul, mul_assoc] + +/-- Coefficients act by ordinary left multiplication. -/ +def coefficientLeft : B →+* AddMonoid.End (Polynomial B) where + toFun b := + { toFun := fun p => C b * p + map_zero' := by simp + map_add' := by intro p q; simp [mul_add] } + map_one' := by + apply AddMonoidHom.ext + intro p + change C (1 : B) * p = p + simp + map_mul' b c := by + apply AddMonoidHom.ext + intro p + change C (b * c) * p = C b * (C c * p) + simp [mul_assoc] + map_zero' := by + apply AddMonoidHom.ext + intro p + change C (0 : B) * p = 0 + simp + map_add' b c := by + apply AddMonoidHom.ext + intro p + change C (b + c) * p = C b * p + C c * p + simp [add_mul] + +/-- Left multiplication by the Ore variable on normal forms. -/ +def leftOreShift (D : OreDivisionDerivation B) : + AddMonoid.End (Polynomial B) where + toFun p := p * X + coefficientDerivation D p + map_zero' := by simp + map_add' p q := by + simp only [add_mul, map_add] + abel + +/-- The faithful left-regular representation of the one-variable Ore model. -/ +def faithfulAmbient (D : OreDivisionDerivation B) : + OreAmbient B (AddMonoid.End (Polynomial B)) D where + embed := coefficientLeft + x := leftOreShift D + relation := by + intro b + apply AddMonoidHom.ext + intro p + change (C b * p) * X + coefficientDerivation D (C b * p) = + C b * (p * X + coefficientDerivation D p) + C (D b) * p + rw [coefficientDerivation_C_mul] + noncomm_ring + +@[simp] lemma coefficientDerivation_X_pow + (D : OreDivisionDerivation B) (n : ℕ) : + coefficientDerivation D (X ^ n) = 0 := by + rw [Polynomial.X_pow_eq_monomial, coefficientDerivation_monomial, + derivation_one, monomial_zero_right] + +@[simp] lemma leftOreShift_X_pow (D : OreDivisionDerivation B) (n : ℕ) : + leftOreShift D (X ^ n) = X ^ (n + 1) := by + change X ^ n * X + coefficientDerivation D (X ^ n) = X ^ (n + 1) + rw [coefficientDerivation_X_pow, add_zero, pow_succ] + +lemma leftOreShift_pow_apply_one (D : OreDivisionDerivation B) (n : ℕ) : + ((leftOreShift D) ^ n) (1 : Polynomial B) = X ^ n := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ'] + change leftOreShift D (((leftOreShift D) ^ n) 1) = X ^ (n + 1) + rw [ih] + exact leftOreShift_X_pow D n + +lemma faithful_eval_apply_one (D : OreDivisionDerivation B) + (p : Polynomial B) : + OreAmbient.eval D (faithfulAmbient D) p (1 : Polynomial B) = p := by + rw [OreAmbient.eval] + change (p.sum fun i b => + coefficientLeft b * (leftOreShift D) ^ i) 1 = p + rw [Polynomial.sum_def] + calc + (∑ n ∈ p.support, + coefficientLeft (p.coeff n) * (leftOreShift D) ^ n) 1 = + (∑ n ∈ p.support, + ⇑(coefficientLeft (p.coeff n) * (leftOreShift D) ^ n)) 1 := by + exact congrFun + (AddMonoidHom.coe_finsetSum + (fun n => coefficientLeft (p.coeff n) * (leftOreShift D) ^ n) + p.support) (1 : Polynomial B) + _ = ∑ n ∈ p.support, + (coefficientLeft (p.coeff n) * (leftOreShift D) ^ n) 1 := by + exact Finset.sum_apply (1 : Polynomial B) p.support + (fun n => ⇑(coefficientLeft (p.coeff n) * (leftOreShift D) ^ n)) + _ = ∑ n ∈ p.support, + C (p.coeff n) * (((leftOreShift D) ^ n) 1) := by rfl + _ = p := by + simp_rw [leftOreShift_pow_apply_one] + simpa only [Polynomial.sum_def] using Polynomial.sum_C_mul_X_pow_eq p + +theorem faithful_eval_injective (D : OreDivisionDerivation B) : + Function.Injective (OreAmbient.eval D (faithfulAmbient D)) := by + intro p q hpq + have h := DFunLike.congr_fun hpq (1 : Polynomial B) + simpa [faithful_eval_apply_one] using h + +lemma faithful_eval_one (D : OreDivisionDerivation B) : + OreAmbient.eval D (faithfulAmbient D) (1 : Polynomial B) = 1 := by + rw [show (1 : Polynomial B) = C (1 : B) by simp, OreAmbient.eval] + rw [Polynomial.sum_C_index] + · simp [faithfulAmbient] + · simp [faithfulAmbient] + +lemma faithful_eval_C (D : OreDivisionDerivation B) (b : B) : + OreAmbient.eval D (faithfulAmbient D) (C b) = coefficientLeft b := by + rw [OreAmbient.eval, Polynomial.sum_C_index] + · simp [faithfulAmbient] + · simp [faithfulAmbient] + +lemma faithful_eval_X (D : OreDivisionDerivation B) : + OreAmbient.eval D (faithfulAmbient D) X = leftOreShift D := by + rw [← Polynomial.monomial_one_one_eq_X] + rw [OreAmbient.eval_monomial] + simp [faithfulAmbient] + +/-- Associativity of the derivation-corrected normal-form product. -/ +theorem rightMul_assoc_of_ring + (D : OreDivisionDerivation B) (p q r : Polynomial B) : + rightMul D (rightMul D p q) r = + rightMul D p (rightMul D q r) := by + apply faithful_eval_injective D + rw [OreAmbient.eval_rightMul, OreAmbient.eval_rightMul, + OreAmbient.eval_rightMul, OreAmbient.eval_rightMul] + exact mul_assoc _ _ _ + +/-! ## The concrete associative Ore ring -/ + +/-- The image of the faithful normal-form representation. -/ +def faithfulRange (D : OreDivisionDerivation B) : + Subring (AddMonoid.End (Polynomial B)) where + carrier := Set.range (OreAmbient.eval D (faithfulAmbient D)) + zero_mem' := ⟨0, OreAmbient.eval_zero D (faithfulAmbient D)⟩ + one_mem' := ⟨1, faithful_eval_one D⟩ + add_mem' := by + rintro _ _ ⟨p, rfl⟩ ⟨q, rfl⟩ + exact ⟨p + q, OreAmbient.eval_add D (faithfulAmbient D) p q⟩ + neg_mem' := by + rintro _ ⟨p, rfl⟩ + exact ⟨-p, map_neg (OreAmbient.evalAddHom D (faithfulAmbient D)) p⟩ + mul_mem' := by + rintro _ _ ⟨p, rfl⟩ ⟨q, rfl⟩ + exact ⟨rightMul D p q, OreAmbient.eval_rightMul D (faithfulAmbient D) p q⟩ + +/-- The one-variable derivation Ore extension, represented faithfully by its +left-regular action on normal polynomials. -/ +abbrev NormalOre (D : OreDivisionDerivation B) := faithfulRange D + +/-- A coefficient-left polynomial regarded as an element of the Ore ring. -/ +def normalForm (D : OreDivisionDerivation B) (p : Polynomial B) : NormalOre D := + ⟨OreAmbient.eval D (faithfulAmbient D) p, ⟨p, rfl⟩⟩ + +@[simp] theorem normalForm_injective (D : OreDivisionDerivation B) : + Function.Injective (normalForm D) := by + intro p q h + apply faithful_eval_injective D + exact Subtype.ext_iff.mp h + +theorem normalForm_surjective (D : OreDivisionDerivation B) : + Function.Surjective (normalForm D) := by + rintro ⟨_, p, rfl⟩ + exact ⟨p, rfl⟩ + +@[simp] theorem normalForm_zero (D : OreDivisionDerivation B) : + normalForm D 0 = 0 := by + apply Subtype.ext + exact OreAmbient.eval_zero D (faithfulAmbient D) + +@[simp] theorem normalForm_one (D : OreDivisionDerivation B) : + normalForm D 1 = 1 := by + apply Subtype.ext + exact faithful_eval_one D + +@[simp] theorem normalForm_add (D : OreDivisionDerivation B) + (p q : Polynomial B) : + normalForm D (p + q) = normalForm D p + normalForm D q := by + apply Subtype.ext + exact OreAmbient.eval_add D (faithfulAmbient D) p q + +@[simp] theorem normalForm_neg (D : OreDivisionDerivation B) + (p : Polynomial B) : normalForm D (-p) = -normalForm D p := by + apply Subtype.ext + exact map_neg (OreAmbient.evalAddHom D (faithfulAmbient D)) p + +@[simp] theorem normalForm_mul (D : OreDivisionDerivation B) + (p q : Polynomial B) : + normalForm D (rightMul D p q) = normalForm D p * normalForm D q := by + apply Subtype.ext + exact OreAmbient.eval_rightMul D (faithfulAmbient D) p q + +/-- The normal-form map as an additive homomorphism. -/ +def normalFormAddHom (D : OreDivisionDerivation B) : + Polynomial B →+ NormalOre D where + toFun := normalForm D + map_zero' := normalForm_zero D + map_add' := normalForm_add D + +/-- Normal forms are additively equivalent to ordinary coefficient-left +polynomials. -/ +def normalFormAddEquiv (D : OreDivisionDerivation B) : + Polynomial B ≃+ NormalOre D := + AddEquiv.ofBijective (normalFormAddHom D) + ⟨normalForm_injective D, normalForm_surjective D⟩ + +/-- The canonical coefficient embedding. -/ +def normalCoefficient (D : OreDivisionDerivation B) : B →+* NormalOre D := + coefficientLeft.codRestrict (faithfulRange D) fun b => by + exact ⟨C b, faithful_eval_C D b⟩ + +@[simp] theorem normalForm_C (D : OreDivisionDerivation B) (b : B) : + normalForm D (C b) = normalCoefficient D b := by + apply Subtype.ext + exact faithful_eval_C D b + +/-- The canonical Ore variable. -/ +def normalVariable (D : OreDivisionDerivation B) : NormalOre D := + normalForm D X + +theorem normalForm_monomial (D : OreDivisionDerivation B) (n : ℕ) (b : B) : + normalForm D (monomial n b) = + normalCoefficient D b * normalVariable D ^ n := by + apply Subtype.ext + change OreAmbient.eval D (faithfulAmbient D) (monomial n b) = + coefficientLeft b * OreAmbient.eval D (faithfulAmbient D) X ^ n + rw [OreAmbient.eval_monomial, faithful_eval_X] + rfl + +/-- The defining derivation relation `X b = b X + D(b)`. -/ +theorem normalVariable_mul_coefficient (D : OreDivisionDerivation B) (b : B) : + normalVariable D * normalCoefficient D b = + normalCoefficient D b * normalVariable D + normalCoefficient D (D b) := by + apply Subtype.ext + change + OreAmbient.eval D (faithfulAmbient D) X * coefficientLeft b = + coefficientLeft b * OreAmbient.eval D (faithfulAmbient D) X + + coefficientLeft (D b) + rw [faithful_eval_X] + exact (faithfulAmbient D).relation b + +/-! ## Universal property -/ + +variable {A : Type*} [Ring A] + +lemma ambient_eval_one (D : OreDivisionDerivation B) (O : OreAmbient B A D) : + OreAmbient.eval D O (1 : Polynomial B) = 1 := by + rw [show (1 : Polynomial B) = C (1 : B) by simp, OreAmbient.eval] + rw [Polynomial.sum_C_index] + · simp + · simp + +lemma ambient_eval_C (D : OreDivisionDerivation B) (O : OreAmbient B A D) + (b : B) : OreAmbient.eval D O (C b) = O.embed b := by + rw [OreAmbient.eval, Polynomial.sum_C_index] + · simp + · simp + +lemma ambient_eval_X (D : OreDivisionDerivation B) (O : OreAmbient B A D) : + OreAmbient.eval D O X = O.x := by + rw [← Polynomial.monomial_one_one_eq_X, OreAmbient.eval_monomial] + simp + +/-- The universal map out of the concrete Ore ring. -/ +def oreLift (D : OreDivisionDerivation B) (O : OreAmbient B A D) : + NormalOre D →+* A where + toFun z := OreAmbient.eval D O ((normalFormAddEquiv D).symm z) + map_zero' := by + change OreAmbient.eval D O ((normalFormAddEquiv D).symm 0) = 0 + rw [(normalFormAddEquiv D).symm.map_zero] + exact OreAmbient.eval_zero D O + map_one' := by + have h : (normalFormAddEquiv D).symm (1 : NormalOre D) = 1 := by + apply (normalFormAddEquiv D).injective + simp [normalFormAddEquiv, normalFormAddHom] + change OreAmbient.eval D O ((normalFormAddEquiv D).symm 1) = 1 + rw [h] + exact ambient_eval_one D O + map_add' z w := by + change OreAmbient.eval D O ((normalFormAddEquiv D).symm (z + w)) = + OreAmbient.eval D O ((normalFormAddEquiv D).symm z) + + OreAmbient.eval D O ((normalFormAddEquiv D).symm w) + have h := (normalFormAddEquiv D).symm.toAddHom.map_add z w + change (normalFormAddEquiv D).symm (z + w) = + (normalFormAddEquiv D).symm z + (normalFormAddEquiv D).symm w at h + rw [h] + exact OreAmbient.eval_add D O _ _ + map_mul' z w := by + let p := (normalFormAddEquiv D).symm z + let q := (normalFormAddEquiv D).symm w + have hz : normalForm D p = z := by + change (normalFormAddEquiv D) p = z + exact (normalFormAddEquiv D).apply_symm_apply z + have hw : normalForm D q = w := by + change (normalFormAddEquiv D) q = w + exact (normalFormAddEquiv D).apply_symm_apply w + have hpq : (normalFormAddEquiv D).symm (z * w) = rightMul D p q := by + apply (normalFormAddEquiv D).injective + rw [(normalFormAddEquiv D).apply_symm_apply] + symm + change normalForm D (rightMul D p q) = z * w + rw [normalForm_mul, hz, hw] + change OreAmbient.eval D O ((normalFormAddEquiv D).symm (z * w)) = + OreAmbient.eval D O p * OreAmbient.eval D O q + rw [hpq] + exact OreAmbient.eval_rightMul D O p q + +@[simp] theorem oreLift_normalForm (D : OreDivisionDerivation B) + (O : OreAmbient B A D) (p : Polynomial B) : + oreLift D O (normalForm D p) = OreAmbient.eval D O p := by + change OreAmbient.eval D O ((normalFormAddEquiv D).symm (normalForm D p)) = _ + rw [show normalForm D p = (normalFormAddEquiv D) p by rfl] + rw [(normalFormAddEquiv D).symm_apply_apply] + +@[simp] theorem oreLift_coefficient (D : OreDivisionDerivation B) + (O : OreAmbient B A D) (b : B) : + oreLift D O (normalCoefficient D b) = O.embed b := by + rw [← normalForm_C, oreLift_normalForm, ambient_eval_C] + +@[simp] theorem oreLift_variable (D : OreDivisionDerivation B) + (O : OreAmbient B A D) : oreLift D O (normalVariable D) = O.x := by + rw [normalVariable, oreLift_normalForm, ambient_eval_X] + +/-- A ring map out of `NormalOre D` is uniquely determined by the coefficient +map and the image of the Ore variable. -/ +theorem oreLift_unique (D : OreDivisionDerivation B) (O : OreAmbient B A D) + (g : NormalOre D →+* A) + (hCoefficient : ∀ b, g (normalCoefficient D b) = O.embed b) + (hVariable : g (normalVariable D) = O.x) : + g = oreLift D O := by + ext z + rcases normalForm_surjective D z with ⟨p, rfl⟩ + rw [oreLift_normalForm] + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [normalForm_add, g.map_add, OreAmbient.eval_add, hp, hq] + | monomial n b => + rw [normalForm_monomial, g.map_mul, g.map_pow, hCoefficient, hVariable, + OreAmbient.eval_monomial] + + +end +end AlgebraicAnalysis.OreAssociativity diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedPBW.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedPBW.lean new file mode 100644 index 0000000000..fe81a92836 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedPBW.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.IteratedTower +import Mathlib.Algebra.Polynomial.Basis +import Mathlib.LinearAlgebra.Basis.Basic + +/-! +# Left-field PBW bases for the finite Ore tower + +This is the noncentral left-module layer. Scalars act through the canonical +coefficient embedding at every stage; no centrality of the coefficient field +inside the Ore ring is used. +-/ + +namespace AlgebraicAnalysis.OreIteratedPBW + +open Polynomial +open Module +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open AlgebraicAnalysis.OreIteratedTower + +noncomputable section + + +variable {K : Type*} [Field K] + +/-- A derivation of the field coefficient ring for an Ore stage. -/ +abbrev KDerivation (K : Type*) [Ring K] := OreDivisionDerivation K + +/-- The coefficient embedding into a finite iterated Ore tower. -/ +def towerCoefficient : (Ds : List (KDerivation K)) → + (hDs : PairwiseCommutes Ds) → K →+* OreTower Ds hDs + | [], _ => RingHom.id K + | D :: Ds, hDs => + let T := build Ds hDs.2 + let hD : CommutesWith D Ds := pairwise_head hDs + (normalCoefficient (T.extend D hD)).comp + (towerCoefficient Ds hDs.2) + +instance towerKModule (Ds : List (KDerivation K)) + (hDs : PairwiseCommutes Ds) : Module K (OreTower Ds hDs) := + Module.compHom (OreTower Ds hDs) (towerCoefficient Ds hDs) + +/-- The nested natural-number index type for tower monomials. -/ +def exponentIndex : List (KDerivation K) → Type + | [] => PUnit + | _ :: Ds => ℕ × exponentIndex Ds + +instance polynomialKSMul (R : Type*) [Semiring R] [Module K R] : + SMul K (Polynomial R) := + Polynomial.distribSMul.toSMul + +instance polynomialKModule (R : Type*) [Semiring R] [Module K R] : + Module K (Polynomial R) := + Polynomial.module + +lemma polynomial_smul_eq_C_mul {R : Type*} [Ring R] [Module K R] + (φ : K →+* R) (hφ : ∀ c : K, ∀ r : R, c • r = φ c * r) + (c : K) (p : Polynomial R) : + c • p = Polynomial.C (φ c) * p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [smul_add, mul_add, hp, hq] + | monomial n r => + apply (Polynomial.toFinsuppIso R).injective + simp [Polynomial.toFinsuppIso, hφ] + +/-- The coefficient-wise additive coordinates of a polynomial. -/ +def polynomialToFinsuppLinearEquiv {R : Type*} [Ring R] + [Module K R] : + Polynomial R ≃ₗ[K] (ℕ →₀ R) := by + exact + { (Polynomial.toFinsuppIso R).toAddEquiv.trans + (AddMonoidAlgebra.coeffLinearEquiv K).toAddEquiv with + map_smul' := by + intro c p + rfl } + +/-- Lift a coefficient basis to the standard polynomial basis. -/ +def polynomialBasis (R : Type*) [Ring R] [Module K R] + (b : Basis ι K R) : + Basis (ℕ × ι) K (Polynomial R) := by + let e : Polynomial R ≃ₗ[K] (ℕ × ι →₀ K) := + (polynomialToFinsuppLinearEquiv (K := K)).trans + ((Finsupp.mapRange.linearEquiv b.repr).trans + (Finsupp.curryLinearEquiv K).symm) + exact Basis.ofRepr e + +/-- The tower normal form as a linear equivalence over the coefficient field. -/ +def normalFormLinearEquivK {R : Type*} [Ring R] + (D : OreDivisionDerivation R) (φ : K →+* R) + (ψ : K →+* NormalOre D) + (hψ : ψ = (normalCoefficient D).comp φ) + [Module K R] [Module K (NormalOre D)] + (hφ : ∀ c : K, ∀ r : R, c • r = φ c * r) + (hsmul : ∀ c : K, ∀ z : NormalOre D, c • z = ψ c * z) : + Polynomial R ≃ₗ[K] NormalOre D := by + exact + { normalFormAddEquiv D with + map_smul' := by + intro c p + change normalForm D (c • p) = c • normalForm D p + rw [polynomial_smul_eq_C_mul φ hφ] + rw [hsmul, hψ] + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [mul_add, normalForm_add, hp, hq, normalForm_add] + noncomm_ring + | monomial n b => + rw [Polynomial.C_mul_monomial, normalForm_monomial] + rw [normalForm_monomial] + simp [mul_assoc] } + +/-- The PBW basis indexed by nested exponent tuples. -/ +def towerPBWBasis : (Ds : List (KDerivation K)) → + (hDs : PairwiseCommutes Ds) → + letI : Module K (OreTower Ds hDs) := towerKModule Ds hDs + Basis (exponentIndex Ds) K (OreTower Ds hDs) + | [], _ => Basis.singleton PUnit K + | D :: Ds, hDs => by + letI : Module K (OreTower (D :: Ds) hDs) := + towerKModule (D :: Ds) hDs + let T := build Ds hDs.2 + let hD : CommutesWith D Ds := pairwise_head hDs + let φ : K →+* T.carrier := towerCoefficient Ds hDs.2 + let ψ : K →+* NormalOre (T.extend D hD) := + (normalCoefficient (T.extend D hD)).comp φ + letI : Module K T.carrier := towerKModule Ds hDs.2 + letI : Module K (NormalOre (T.extend D hD)) := + towerKModule (D :: Ds) hDs + let b : Basis (exponentIndex Ds) K T.carrier := + towerPBWBasis Ds hDs.2 + let pb : Basis (ℕ × exponentIndex Ds) K (Polynomial T.carrier) := + polynomialBasis (K := K) T.carrier b + exact (pb.map (normalFormLinearEquivK (K := K) + (T.extend D hD) φ ψ rfl (by intro c r; rfl) (by intro c z; rfl))) + + +end +end AlgebraicAnalysis.OreIteratedPBW diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedTower.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedTower.lean new file mode 100644 index 0000000000..b8f5f00391 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/IteratedTower.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Tower + +/-! +# Finite iterated derivation-Ore towers + +For a finite list of pairwise commuting coefficient derivations, this file +builds the corresponding iterated normal Ore ring. The construction stores, +at every stage, the lift of every further commuting derivation and the proof +that such lifts commute. Thus the construction can be iterated without any +new compatibility postulate. + +The final result is an additive iterated normal-form equivalence. Operator +faithfulness and freeness over a rational Weyl subring are deliberately not +asserted here. +-/ + +namespace AlgebraicAnalysis.OreIteratedTower + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open AlgebraicAnalysis.OreTower + +noncomputable section + + +universe u + +variable {B : Type u} [Ring B] + +/-- A derivation used to build one stage of an iterated Ore tower. -/ +abbrev Derivation (B : Type u) [Ring B] := OreDivisionDerivation B + +/-- Commutation of two coefficient derivations. -/ +def Commutes (D E : Derivation B) : Prop := + ∀ b : B, D (E b) = E (D b) + +/-- Pairwise commutation for a finite ordered family. -/ +def PairwiseCommutes : List (Derivation B) → Prop + | [] => True + | D :: Ds => + (∀ E ∈ Ds, Commutes D E) ∧ PairwiseCommutes Ds + +/-- Commutation of one derivation with every member of a list. -/ +def CommutesWith (D : Derivation B) : List (Derivation B) → Prop + | Es => ∀ E ∈ Es, Commutes D E + +lemma commutes_symm {D E : Derivation B} (h : Commutes D E) : + Commutes E D := by + intro b + exact (h b).symm + +lemma pairwise_tail {D : Derivation B} {Ds : List (Derivation B)} + (h : PairwiseCommutes (D :: Ds)) : PairwiseCommutes Ds := + h.2 + +lemma pairwise_head {D : Derivation B} {Ds : List (Derivation B)} + (h : PairwiseCommutes (D :: Ds)) : CommutesWith D Ds := by + exact h.1 + +lemma commutesWith_tail {D E : Derivation B} {Es : List (Derivation B)} + (h : CommutesWith D (E :: Es)) : CommutesWith D Es := + fun F hF => h F (by simp [hF]) + +lemma commutes_refl (D : Derivation B) : Commutes D D := by + intro b + rfl + +/-! ## A recursive tower bundle -/ + +/-- +`TowerBuild Ds h` contains the carrier ring for the tower on `Ds`, together +with the lift of any derivation commuting with `Ds`. Bundling the lifts and +their commutation proof avoids a circular definition of the tower type. +-/ +structure TowerBuild (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) where + /-- The carrier type of the recursively built tower. -/ + carrier : Type u + /-- The ring structure on the tower carrier. -/ + ring : Ring carrier + /-- Extend a commuting coefficient derivation through the tower. -/ + extend : ∀ (D : Derivation B), CommutesWith D Ds → + OreDivisionDerivation carrier + extend_commutes : ∀ (D E : Derivation B) + (hD : CommutesWith D Ds) (hE : CommutesWith E Ds), Commutes D E → + Commutes (B := carrier) (extend D hD) (extend E hE) + +/-- Recursively construct the finite commuting derivation-Ore tower. -/ +def build : (Ds : List (Derivation B)) → + (hDs : PairwiseCommutes Ds) → TowerBuild Ds hDs + | [], _ => + { carrier := B + ring := inferInstance + extend := fun D _ => D + extend_commutes := by + intro D E _ _ hDE + exact hDE } + | E :: Es, hDs => by + let T := build Es hDs.2 + letI : Ring T.carrier := T.ring + let hE : CommutesWith E Es := pairwise_head hDs + let DE : OreDivisionDerivation T.carrier := T.extend E hE + refine + { carrier := NormalOre DE + ring := inferInstance + extend := ?_ + extend_commutes := ?_ } + · intro D hD + exact liftDerivation DE (T.extend D (commutesWith_tail hD)) + (T.extend_commutes E D hE (commutesWith_tail hD) + (commutes_symm (hD E (by simp)))) + · intro D F hD hF hDF + exact liftDerivation_commute DE + (T.extend D (commutesWith_tail hD)) + (T.extend F (commutesWith_tail hF)) + (T.extend_commutes E D hE (commutesWith_tail hD) + (commutes_symm (hD E (by simp)))) + (T.extend_commutes E F hE (commutesWith_tail hF) + (commutes_symm (hF E (by simp)))) + (T.extend_commutes D F (commutesWith_tail hD) + (commutesWith_tail hF) hDF) + +/-- The carrier ring of the finite iterated tower. -/ +abbrev OreTower (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) : Type u := (build Ds hDs).carrier + +instance oreTowerRing (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) : Ring (OreTower Ds hDs) := + (build Ds hDs).ring + +/-- The recursively lifted version of a coefficient derivation. -/ +def extendThrough (D : Derivation B) (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) (hD : CommutesWith D Ds) : + OreDivisionDerivation (OreTower Ds hDs) := + (build Ds hDs).extend D hD + +theorem extendThrough_commutes (D E : Derivation B) + (Ds : List (Derivation B)) (hDs : PairwiseCommutes Ds) + (hD : CommutesWith D Ds) (hE : CommutesWith E Ds) + (hDE : Commutes D E) : + Commutes (extendThrough D Ds hDs hD) + (extendThrough E Ds hDs hE) := + (build Ds hDs).extend_commutes D E hD hE hDE + +/-! ## Iterated normal forms -/ + +/-- A nested polynomial carrier together with the ring instance it needs. -/ +structure PolynomialBuild (Ds : List (Derivation B)) where + /-- The nested polynomial carrier. -/ + carrier : Type u + /-- The ring structure on the nested polynomial carrier. -/ + ring : Ring carrier + +/-- Recursively construct the nested polynomial coefficient carrier. -/ +def polynomialBuild : (Ds : List (Derivation B)) → PolynomialBuild Ds + | [] => + { carrier := B + ring := inferInstance } + | _ :: Ds => by + let P := polynomialBuild Ds + letI : Ring P.carrier := P.ring + exact { carrier := Polynomial P.carrier + ring := inferInstance } + +/-- Nested coefficient-left polynomial data for the tower. -/ +abbrev iteratedPolynomial (Ds : List (Derivation B)) : Type u := + (polynomialBuild Ds).carrier + +instance iteratedPolynomialRing (Ds : List (Derivation B)) : + Ring (iteratedPolynomial Ds) := + (polynomialBuild Ds).ring + +/-- Additive equivalence between nested polynomial data and the Ore tower. -/ +def iteratedNormalForm : (Ds : List (Derivation B)) → + (hDs : PairwiseCommutes Ds) → + iteratedPolynomial Ds ≃+ OreTower Ds hDs + | [], _ => AddEquiv.refl B + | D :: Ds, hDs => by + let T := build Ds hDs.2 + let P := polynomialBuild Ds + letI : Ring P.carrier := P.ring + let hD : CommutesWith D Ds := pairwise_head hDs + let e : P.carrier ≃+ T.carrier := + iteratedNormalForm Ds hDs.2 + let pCoeff : AddMonoidAlgebra P.carrier ℕ ≃+ (ℕ →₀ P.carrier) := + AddMonoidAlgebra.coeffAddEquiv + let tCoeff : AddMonoidAlgebra T.carrier ℕ ≃+ (ℕ →₀ T.carrier) := + AddMonoidAlgebra.coeffAddEquiv + let ep : Polynomial P.carrier ≃+ + Polynomial T.carrier := + (Polynomial.toFinsuppIso P.carrier).toAddEquiv.trans + (pCoeff.trans + ((Finsupp.mapRange.addEquiv (ι := ℕ) e).trans + (tCoeff.symm.trans + (Polynomial.toFinsuppIso T.carrier).toAddEquiv.symm))) + exact ep.trans (normalFormAddEquiv (T.extend D hD)) + +theorem iteratedNormalForm_injective (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) : + Function.Injective (iteratedNormalForm Ds hDs) := + (iteratedNormalForm Ds hDs).injective + +theorem iteratedNormalForm_surjective (Ds : List (Derivation B)) + (hDs : PairwiseCommutes Ds) : + Function.Surjective (iteratedNormalForm Ds hDs) := + (iteratedNormalForm Ds hDs).surjective + + +end +end AlgebraicAnalysis.OreIteratedTower diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LeftPBW.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LeftPBW.lean new file mode 100644 index 0000000000..0474166b0b --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LeftPBW.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import Mathlib.Algebra.Polynomial.Basis +import Mathlib.LinearAlgebra.Basis.Basic + +/-! +# Left PBW basis for a derivation Ore extension + +The normal-form Ore +ring is a left module over its coefficient field even when the derivation is +nonzero (and hence the coefficient field is not central). Transporting the +ordinary polynomial monomial basis across the checked normal-form equivalence +gives the expected basis `1, ∂, ∂², ...`. + +The iterated tower still needs the commuting derivations to be extended over +earlier stages. Nothing in this file postulates such extensions. +-/ + +namespace AlgebraicAnalysis.OreLeftPBW + +open Polynomial +open Module +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + + +variable {K : Type*} [Field K] + +/-- The coefficient field acts on an Ore extension by multiplication on the +left through the canonical coefficient embedding. Centrality is neither +assumed nor needed. -/ +instance normalOreLeftModule (D : OreDivisionDerivation K) : + Module K (NormalOre D) := + Module.compHom (NormalOre D) (normalCoefficient D) + +theorem normalForm_smul_left (D : OreDivisionDerivation K) + (c : K) (p : Polynomial K) : + normalForm D (c • p) = c • normalForm D p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [smul_add, normalForm_add, normalForm_add, hp, hq, smul_add] + | monomial n b => + rw [Polynomial.smul_monomial, normalForm_monomial, + normalForm_monomial] + change normalCoefficient D (c * b) * normalVariable D ^ n = + normalCoefficient D c * + (normalCoefficient D b * normalVariable D ^ n) + rw [map_mul, mul_assoc] + +/-- Coefficient-left Ore normal form as a linear equivalence over the +coefficient field. -/ +def leftNormalFormLinearEquiv (D : OreDivisionDerivation K) : + Polynomial K ≃ₗ[K] NormalOre D := + { normalFormAddEquiv D with + map_smul' := normalForm_smul_left D } + +@[simp] theorem leftNormalFormLinearEquiv_apply + (D : OreDivisionDerivation K) (p : Polynomial K) : + leftNormalFormLinearEquiv D p = normalForm D p := rfl + +/-- The powers of the Ore variable form a left basis over the coefficient +field. -/ +def orePBWBasis (D : OreDivisionDerivation K) : Basis ℕ K (NormalOre D) := + (Polynomial.basisMonomials K).map (leftNormalFormLinearEquiv D) + +@[simp] theorem orePBWBasis_apply (D : OreDivisionDerivation K) (n : ℕ) : + orePBWBasis D n = normalVariable D ^ n := by + rw [orePBWBasis, Basis.map_apply, Polynomial.coe_basisMonomials] + change normalForm D (Polynomial.monomial n 1) = normalVariable D ^ n + rw [normalForm_monomial, map_one, one_mul] + +/-- Every element has a unique finite coefficient-left expansion in powers +of the Ore variable. -/ +theorem orePBW_repr_symm_single (D : OreDivisionDerivation K) + (n : ℕ) (c : K) : + (orePBWBasis D).repr.symm (Finsupp.single n c) = + normalCoefficient D c * normalVariable D ^ n := by + rw [(orePBWBasis D).repr_symm_single, orePBWBasis_apply] + rfl + + +end +end AlgebraicAnalysis.OreLeftPBW diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Localization.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Localization.lean new file mode 100644 index 0000000000..817828c12d --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Localization.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.OreLocalization.Ring + +/-! +# Generic Ore-localization facts + +This file records unconditional fraction and denominator results used by a +stage argument. The common-denominator lemma is proved directly from the +Ore condition. No flatness, Noetherianity, or freeness of a localized ring +over a stage ring is assumed. +-/ + +namespace AlgebraicAnalysis +namespace OreStageLocalization + +open OreLocalization +open nonZeroDivisors + +universe u + +section CommonDenominators + +variable {R : Type u} [Monoid R] +variable {S : Submonoid R} [OreSet S] + +/-- A finite family of Ore denominators has a common left multiple. -/ +theorem exists_common_left_multiple (s : Finset S) : + ∃ t : S, ∀ a ∈ s, ∃ u : R, (t : R) = u * (a : R) := by + classical + induction s using Finset.induction_on with + | empty => + refine ⟨1, ?_⟩ + simp + | @insert a s ha ih => + rcases ih with ⟨t, ht⟩ + rcases oreCondition (t : R) a with ⟨u, v, huv⟩ + refine ⟨v * t, ?_⟩ + intro b hb + rcases Finset.mem_insert.mp hb with rfl | hb + · exact ⟨u, huv⟩ + · rcases ht b hb with ⟨w, hw⟩ + refine ⟨(v : R) * w, ?_⟩ + simpa [Submonoid.coe_mul, hw, mul_assoc] + +end CommonDenominators + +section FractionRepresentation + +variable {R : Type u} [Ring R] [Nontrivial R] [NoZeroDivisors R] +variable {S : Submonoid R} [OreSet S] + +/-- Every element of an Ore localization has an explicit numerator/denominator form. -/ +@[nolint unusedArguments] +theorem exists_fraction (x : R[S⁻¹]) : + ∃ r : R, ∃ s : S, x = r /ₒ s := by + induction x using OreLocalization.ind with + | _ r s => exact ⟨r, s, rfl⟩ + +/-- A nonzero localized element has a representative with nonzero numerator. -/ +@[nolint unusedArguments] +theorem exists_ne_zero_numerator {x : R[S⁻¹]} (hx : x ≠ 0) : + ∃ r : R, r ≠ 0 ∧ ∃ s : S, x = r /ₒ s := by + induction x using OreLocalization.ind with + | _ r s => + refine ⟨r, ?_, s, rfl⟩ + intro hr + apply hx + subst r + exact OreLocalization.zero_oreDiv' s + +/-- Under a right non-zero-divisor hypothesis, the numerator embedding is injective. -/ +theorem numerator_injective (hS : S ≤ nonZeroDivisorsRight R) : + Function.Injective (OreLocalization.numeratorHom : R → R[S⁻¹]) := + OreLocalization.numeratorHom_inj <| by + intro s hs + rw [mem_nonZeroDivisorsLeft_iff] + intro y hsy + have hs0 : (s : R) ≠ 0 := by + intro hs0 + have h1 : (1 : R) = 0 := hS hs 1 (by simp [hs0]) + exact one_ne_zero h1 + exact (mul_eq_zero.mp hsy).resolve_left hs0 + +/-- Every chosen denominator becomes a unit in an Ore localization. -/ +@[nolint unusedArguments] +theorem denominator_isUnit (s : S) : + IsUnit (OreLocalization.numeratorHom (s : R) : R[S⁻¹]) := + OreLocalization.numerator_isUnit s + +end FractionRepresentation + +section FullFractionRing + +variable {R : Type u} [Ring R] [Nontrivial R] [NoZeroDivisors R] +variable [OreLocalization.OreSet R⁰] + +/-- Every nonzero numerator is a unit in the full Ore division-ring localization. -/ +theorem nonzero_numerator_isUnit {r : R} (hr : r ≠ 0) : + IsUnit (OreLocalization.numeratorHom r : R[R⁰⁻¹]) := by + simpa using + (OreLocalization.numerator_isUnit + (⟨r, mem_nonZeroDivisors_of_ne_zero hr⟩ : R⁰)) + +/-- Every nonzero element of the full Ore localization is a unit. -/ +theorem full_isUnit_of_ne_zero {x : R[R⁰⁻¹]} (hx : x ≠ 0) : IsUnit x := + isUnit_iff_ne_zero.mpr hx + +end FullFractionRing + + +end OreStageLocalization +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LocalizationExtension.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LocalizationExtension.lean new file mode 100644 index 0000000000..ea897bfb16 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/LocalizationExtension.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import Mathlib.RingTheory.OreLocalization.Ring + +/-! +# Localization interface for derivation-Ore extensions + +The proposition below is the exact output expected from a theorem saying that +localizing a derivation-Ore extension at coefficients gives the derivation-Ore +extension of the localized coefficient ring. It packages data and its +compatibility law; it does not assert that the data exist. +-/ + +namespace AlgebraicAnalysis +namespace OreLocalizationExtension + +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open OreLocalization + +/-- Existence of data identifying the localization of `NormalOre D` along coefficient +denominators with a derivation-Ore extension of the localized coefficient +ring. Ore-ness of both denominator sets remains an explicit hypothesis. -/ +def IsDerivationOreLocalization + {B : Type*} [Ring B] + (D : OreDivisionDerivation B) (S : Submonoid B) + [OreSet S] + [OreSet (S.map (normalCoefficient D).toMonoidHom)] : Prop := + ∃ (D' : OreDivisionDerivation (B[S⁻¹])) + (e : (NormalOre D)[(S.map (normalCoefficient D).toMonoidHom)⁻¹] ≃+* + NormalOre D'), + ∀ b : B, + e (numeratorHom (normalCoefficient D b)) = + normalCoefficient D' (numeratorHom b) + +end OreLocalizationExtension +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/PrincipalRightIdeal.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/PrincipalRightIdeal.lean new file mode 100644 index 0000000000..6dd5523f76 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/PrincipalRightIdeal.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightQuotient + +/-! +# Principal right ideals in a derivation Ore normal form + +This module isolates the generic minimal-degree and right-principal-ideal +arguments for a derivation Ore extension over a division ring. The +coefficient ring may be noncommutative. The right-sided orientation is +explicit: division has the divisor on the left and the quotient on the right. + +No simplicity, localization, or left-PID statement is asserted here. +-/ + +namespace AlgebraicAnalysis.OrePrincipalRightIdeal + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + +variable {B : Type*} [DivisionRing B] + +lemma rightMul_C_left (D : OreDivisionDerivation B) (c : B) (p : Polynomial B) : + OreDivision.rightMul D (Polynomial.C c) p = Polynomial.C c * p := by + apply Polynomial.ext + intro n + rw [OreDivision.rightMul, Polynomial.coeff_sum] + rw [Polynomial.sum_def] + by_cases hc : c = 0 + · subst c + simp [OreDivision.rightMulMonomial_coeff] + · simp only [OreDivision.rightMulMonomial_coeff] + rw [Polynomial.support_C hc] + simp [hc] + +lemma rightMul_coeff_C_top (D : OreDivisionDerivation B) (p : Polynomial B) + (b : B) (hp : p ≠ 0) : + (OreDivision.rightMul D p (Polynomial.C b)).coeff p.natDegree = + p.leadingCoeff * b := by + rw [OreDivision.rightMul, Polynomial.coeff_sum] + rw [Polynomial.sum_def] + by_cases hb : b = 0 + · subst b + simp + · rw [Polynomial.support_C hb] + simp + exact OreDivision.rightMulMonomial_coeff_top D p hp b 0 + +lemma degree_lt_of_degree_le_of_coeff_zero + (p : Polynomial B) (n : ℕ) (hdeg : p.degree ≤ (n : WithBot ℕ)) + (hcoef : p.coeff n = 0) : + p.degree < (n : WithBot ℕ) := by + rw [Polynomial.degree_lt_iff_coeff_zero] + intro m hnm + by_cases hmn : m = n + · simpa [hmn] using hcoef + · have hnm' : n < m := lt_of_le_of_ne hnm (Ne.symm hmn) + apply Polynomial.coeff_eq_zero_of_degree_lt + exact lt_of_le_of_lt hdeg (WithBot.coe_lt_coe.mpr hnm') + +/-- A monic minimum-degree member of a two-sided ideal commutes with every +coefficient. This is a minimal-degree reduction, not a simplicity theorem. -/ +theorem minimal_monic_member_commutes_coefficients + (D : OreDivisionDerivation B) (I : TwoSidedIdeal (NormalOre D)) + (p : Polynomial B) (hp : p.Monic) (hpI : normalForm D p ∈ I) + (hmin : ∀ q : Polynomial B, q ≠ 0 → normalForm D q ∈ I → + p.natDegree ≤ q.natDegree) (b : B) : + OreDivision.rightMul D p (Polynomial.C b) = + OreDivision.rightMul D (Polynomial.C b) p := by + let q := OreDivision.rightMul D p (Polynomial.C b) - + OreDivision.rightMul D (Polynomial.C b) p + have hqI : normalForm D q ∈ I := by + have hright : normalForm D (OreDivision.rightMul D p (Polynomial.C b)) ∈ I := by + rw [normalForm_mul] + exact I.mul_mem_right _ _ hpI + have hleft : normalForm D (OreDivision.rightMul D (Polynomial.C b) p) ∈ I := by + rw [normalForm_mul] + exact I.mul_mem_left _ _ hpI + change normalForm D + (OreDivision.rightMul D p (Polynomial.C b) + + -OreDivision.rightMul D (Polynomial.C b) p) ∈ I + rw [normalForm_add, normalForm_neg] + exact I.sub_mem hright hleft + have hqdeg : q.degree ≤ (p.natDegree : WithBot ℕ) := by + apply le_trans (degree_sub_le _ _) + apply max_le + · have h := OreDivision.rightMul_degree_le D p (Polynomial.C b) + simpa using h + · have h := OreDivision.rightMul_degree_le D (Polynomial.C b) p + simpa using h + have hqcoef : q.coeff p.natDegree = 0 := by + dsimp [q] + rw [Polynomial.coeff_sub, rightMul_coeff_C_top D p b hp.ne_zero, + rightMul_C_left] + rw [Polynomial.coeff_C_mul] + simp [hp.leadingCoeff] + have hqlt : q.degree < (p.natDegree : WithBot ℕ) := + degree_lt_of_degree_le_of_coeff_zero q p.natDegree hqdeg hqcoef + by_cases hq0 : q = 0 + · exact sub_eq_zero.mp hq0 + · have hnat : p.natDegree ≤ q.natDegree := hmin q hq0 hqI + have hqdeg' : q.degree = (q.natDegree : WithBot ℕ) := + Polynomial.degree_eq_natDegree hq0 + rw [hqdeg'] at hqlt + have hltNat : q.natDegree < p.natDegree := WithBot.coe_lt_coe.mp hqlt + exact False.elim ((not_le_of_gt hltNat) hnat) + +/-- Every nonzero two-sided ideal has a monic member of minimum normal-form +degree. The leading coefficient is normalized within the ideal. -/ +theorem exists_monic_minimal_member + (D : OreDivisionDerivation B) (I : TwoSidedIdeal (NormalOre D)) + (hI : ∃ z : NormalOre D, z ∈ I ∧ z ≠ 0) : + ∃ p : Polynomial B, p.Monic ∧ normalForm D p ∈ I ∧ + ∀ q : Polynomial B, q ≠ 0 → normalForm D q ∈ I → + p.natDegree ≤ q.natDegree := by + classical + obtain ⟨z, hzI, hz0⟩ := hI + obtain ⟨p, rfl⟩ := normalForm_surjective D z + have hp0 : p ≠ 0 := by + intro hp + apply hz0 + simpa [hp] using (normalForm_zero D) + let P : ℕ → Prop := fun n => ∃ q : Polynomial B, + q ≠ 0 ∧ normalForm D q ∈ I ∧ q.natDegree = n + have hex : ∃ n, P n := ⟨p.natDegree, p, hp0, hzI, rfl⟩ + let n : ℕ := Nat.find hex + obtain ⟨p₀, hp₀0, hp₀I, hp₀deg⟩ := Nat.find_spec hex + let c : B := p₀.leadingCoeff⁻¹ + let p' : Polynomial B := Polynomial.C c * p₀ + have hc : c ≠ 0 := by + dsimp [c] + exact inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hp₀0) + have hp'0 : p' ≠ 0 := by + dsimp [p'] + exact mul_ne_zero (Polynomial.C_ne_zero.mpr hc) hp₀0 + have hnat : p'.natDegree = p₀.natDegree := by + have hdeg : p'.degree = p₀.degree := by + dsimp [p'] + exact Polynomial.degree_C_mul hc + rw [Polynomial.degree_eq_natDegree hp'0, + Polynomial.degree_eq_natDegree hp₀0] at hdeg + exact WithBot.coe_eq_coe.mp hdeg + have hp'I : normalForm D p' ∈ I := by + dsimp [p'] + rw [← rightMul_C_left] + rw [normalForm_mul] + exact I.mul_mem_left _ _ hp₀I + have hp'Monic : p'.Monic := by + change p'.leadingCoeff = 1 + change p'.coeff p'.natDegree = 1 + rw [hnat, + Polynomial.coeff_C_mul, Polynomial.coeff_natDegree] + dsimp [c] + exact inv_mul_cancel₀ (Polynomial.leadingCoeff_ne_zero.mpr hp₀0) + refine ⟨p', hp'Monic, hp'I, ?_⟩ + intro q hq hqI + have hqn : P q.natDegree := ⟨q, hq, hqI, rfl⟩ + have hnle : n ≤ q.natDegree := Nat.find_min' hex hqn + calc + p'.natDegree = p₀.natDegree := hnat + _ = n := hp₀deg + _ ≤ q.natDegree := hnle + +/-! +The remaining declarations are the right-sided Euclidean/PID stage for a +normal-form differential Ore extension. They use the same leading-term +argument and make no claim about left ideals. +-/ + +/-- The right ideal generated by a normal-form polynomial. -/ +def normalOrePrincipalRightIdeal (D : OreDivisionDerivation B) (p : Polynomial B) : + Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D) := + Submodule.span (NormalOre D)ᵐᵒᵖ ({normalForm D p} : Set (NormalOre D)) + +/-- The right ideal generated by an arbitrary element of `NormalOre D`. -/ +def normalOrePrincipalRightIdealElement (D : OreDivisionDerivation B) + (a : NormalOre D) : + Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D) := + Submodule.span (NormalOre D)ᵐᵒᵖ ({a} : Set (NormalOre D)) + +/-- Right Euclidean division transported from polynomial normal form. -/ +theorem normalOre_right_division [Nontrivial B] + (D : OreDivisionDerivation B) (d : Polynomial B) (hd : d.Monic) + (a : NormalOre D) : + ∃ q r : Polynomial B, + a = normalForm D (OreDivision.rightMul D d q) + normalForm D r ∧ + (r = 0 ∨ r.natDegree < d.natDegree) := by + obtain ⟨p, rfl⟩ := normalForm_surjective D a + obtain ⟨q, r, hdiv, hrem⟩ := right_division_exists D d p hd + refine ⟨q, r, ?_, hrem⟩ + rw [hdiv, normalForm_add] + +lemma rightMul_C_degree_eq (D : OreDivisionDerivation B) (p : Polynomial B) + (c : B) (hp : p ≠ 0) (hc : c ≠ 0) : + (OreDivision.rightMul D p (Polynomial.C c)).degree = p.degree := by + have hle := OreDivision.rightMul_degree_le D p (Polynomial.C c) + have hle' : (OreDivision.rightMul D p (Polynomial.C c)).degree ≤ + (p.natDegree : WithBot ℕ) := by simpa using hle + have htop : (OreDivision.rightMul D p (Polynomial.C c)).coeff p.natDegree = + p.leadingCoeff * c := by + exact rightMul_coeff_C_top D p c hp + have htop0 : (OreDivision.rightMul D p (Polynomial.C c)).coeff p.natDegree ≠ 0 := by + rw [htop] + exact mul_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hp) hc + have hge : (p.natDegree : WithBot ℕ) ≤ + (OreDivision.rightMul D p (Polynomial.C c)).degree := by + by_contra hnot + have hlt : (OreDivision.rightMul D p (Polynomial.C c)).degree < + (p.natDegree : WithBot ℕ) := lt_of_not_ge hnot + exact htop0 (Polynomial.coeff_eq_zero_of_degree_lt hlt) + rw [Polynomial.degree_eq_natDegree hp] + exact le_antisymm hle' hge + +/-- A nonzero right submodule has a monic member of minimum normal-form +degree. Normalization uses right multiplication by the inverse coefficient. -/ +theorem exists_monic_minimal_right_member + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) + (hI : ∃ z : NormalOre D, z ∈ I ∧ z ≠ 0) : + ∃ p : Polynomial B, p.Monic ∧ normalForm D p ∈ I ∧ + ∀ q : Polynomial B, q ≠ 0 → normalForm D q ∈ I → + p.natDegree ≤ q.natDegree := by + classical + obtain ⟨z, hzI, hz0⟩ := hI + obtain ⟨p, rfl⟩ := normalForm_surjective D z + have hp0 : p ≠ 0 := by + intro hp + apply hz0 + simpa [hp] using (normalForm_zero D) + let P : ℕ → Prop := fun n => ∃ q : Polynomial B, + q ≠ 0 ∧ normalForm D q ∈ I ∧ q.natDegree = n + have hex : ∃ n, P n := ⟨p.natDegree, p, hp0, hzI, rfl⟩ + let n : ℕ := Nat.find hex + obtain ⟨p₀, hp₀0, hp₀I, hp₀deg⟩ := Nat.find_spec hex + let c : B := p₀.leadingCoeff⁻¹ + let p' : Polynomial B := OreDivision.rightMul D p₀ (Polynomial.C c) + have hc : c ≠ 0 := by + dsimp [c] + exact inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hp₀0) + have hp'0 : p' ≠ 0 := by + intro hz + have hz' := congrArg (fun z : Polynomial B => z.coeff p₀.natDegree) hz + change (OreDivision.rightMul D p₀ (Polynomial.C c)).coeff p₀.natDegree = 0 at hz' + rw [rightMul_coeff_C_top D p₀ c hp₀0] at hz' + exact (mul_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hp₀0) hc) hz' + have hdeg : p'.degree = p₀.degree := by + dsimp [p'] + exact rightMul_C_degree_eq D p₀ c hp₀0 hc + have hnat : p'.natDegree = p₀.natDegree := by + rw [Polynomial.degree_eq_natDegree hp'0, + Polynomial.degree_eq_natDegree hp₀0] at hdeg + exact WithBot.coe_eq_coe.mp hdeg + have hp'I : normalForm D p' ∈ I := by + dsimp [p'] + rw [normalForm_mul] + rw [← op_smul_eq_mul] + exact I.smul_mem (MulOpposite.op (normalForm D (Polynomial.C c))) hp₀I + have hp'Monic : p'.Monic := by + change p'.leadingCoeff = 1 + change p'.coeff p'.natDegree = 1 + have htop := rightMul_coeff_C_top D p₀ c hp₀0 + rw [hnat] + dsimp [p'] + rw [htop] + dsimp [c] + exact mul_inv_cancel₀ (Polynomial.leadingCoeff_ne_zero.mpr hp₀0) + refine ⟨p', hp'Monic, hp'I, ?_⟩ + intro q hq hqI + have hqn : P q.natDegree := ⟨q, hq, hqI, rfl⟩ + have hnle : n ≤ q.natDegree := Nat.find_min' hex hqn + calc + p'.natDegree = p₀.natDegree := hnat + _ = n := hp₀deg + _ ≤ q.natDegree := hnle + +/-- Every nonzero right ideal is generated by one monic normal-form element. +The ideal equality is on the right: `I = p (NormalOre D)`. -/ +theorem rightIdeal_eq_principal_of_nonzero + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) + (hI : ∃ z : NormalOre D, z ∈ I ∧ z ≠ 0) : + ∃ p : Polynomial B, p.Monic ∧ + I = normalOrePrincipalRightIdeal D p := by + obtain ⟨p, hp, hpI, hmin⟩ := exists_monic_minimal_right_member D I hI + refine ⟨p, hp, ?_⟩ + apply le_antisymm + · intro z hz + change z ∈ Submodule.span (NormalOre D)ᵐᵒᵖ + ({normalForm D p} : Set (NormalOre D)) + obtain ⟨q, rfl⟩ := normalForm_surjective D z + obtain ⟨u, r, hdecomp, hrem⟩ := right_division_exists D p q hp + have hprod : normalForm D (OreDivision.rightMul D p u) ∈ I := by + rw [normalForm_mul] + rw [← op_smul_eq_mul] + exact I.smul_mem (MulOpposite.op (normalForm D u)) hpI + have hrI : normalForm D r ∈ I := by + have hqeq : normalForm D q = + normalForm D (OreDivision.rightMul D p u) + normalForm D r := by + rw [← normalForm_add, ← hdecomp] + have hsub := I.sub_mem hz hprod + rw [hqeq] at hsub + simpa using hsub + have hr0 : r = 0 := by + by_cases hr : r = 0 + · exact hr + · have hlt := hrem.resolve_left hr + have hcontr := hmin r hr hrI + exact False.elim ((Nat.not_lt_of_ge hcontr) hlt) + subst r + rw [hdecomp, add_zero, normalForm_mul] + rw [← op_smul_eq_mul] + exact Submodule.smul_mem _ _ (Submodule.subset_span (by simp)) + · apply Submodule.span_le.2 + intro z hz + rcases Set.mem_singleton_iff.mp hz with rfl + exact hpI + +/-- Every right ideal of `NormalOre D` is principal, including the zero ideal. +This is a one-sided PID statement; no left-PID claim is made. -/ +theorem rightIdeal_isPrincipal + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) : + ∃ a : NormalOre D, I = normalOrePrincipalRightIdealElement D a := by + by_cases hI : ∃ z : NormalOre D, z ∈ I ∧ z ≠ 0 + · obtain ⟨p, hp, hEq⟩ := rightIdeal_eq_principal_of_nonzero D I hI + exact ⟨normalForm D p, hEq⟩ + · have hbot : I = ⊥ := by + apply le_antisymm + · intro z hz + by_contra hz0 + exact hI ⟨z, hz, hz0⟩ + · exact bot_le + have hzero : normalOrePrincipalRightIdealElement D (0 : NormalOre D) = ⊥ := by + apply le_antisymm + · apply Submodule.span_le.2 + intro z hz + simpa using hz + · exact bot_le + refine ⟨0, ?_⟩ + rw [hbot, hzero] + + +end + +end AlgebraicAnalysis.OrePrincipalRightIdeal diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightDivision.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightDivision.lean new file mode 100644 index 0000000000..3851a9eed9 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightDivision.lean @@ -0,0 +1,1241 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Right division in a coefficient-left derivation Ore model + +This file is the next structural layer after `ore_derivation.lean`. It does +not identify a presented Weyl algebra with this model. It builds the finite +normal-form algebra needed for that identification: the normal form of +`x^i * b`, the right product of a normal polynomial by a monomial `b*x^j`, +and the leading-term fact which drives right division by a monic polynomial. + +The coefficient ring is allowed to be noncommutative. No commutative +polynomial division theorem is used. +-/ + +namespace AlgebraicAnalysis + +noncomputable section + +/-- A derivation used to define a coefficient-left Ore normal form. -/ +structure OreDivisionDerivation (B : Type*) [Ring B] where + /-- The underlying additive derivation map. -/ + toFun : B → B + /-- The derivation preserves zero. -/ + map_zero' : toFun 0 = 0 + /-- The derivation preserves addition. -/ + map_add' : ∀ a b, toFun (a + b) = toFun a + toFun b + /-- The Leibniz rule. -/ + leibniz' : ∀ a b, toFun (a * b) = a * toFun b + toFun a * b + +instance {B : Type*} [Ring B] : CoeFun (OreDivisionDerivation B) (fun _ => B → B) := + ⟨OreDivisionDerivation.toFun⟩ + +namespace OreDivisionDerivation + +variable {B : Type*} [Ring B] (D : OreDivisionDerivation B) + +@[simp] theorem map_zero : D 0 = 0 := D.map_zero' + +@[simp] theorem map_add (a b : B) : D (a + b) = D a + D b := D.map_add' a b + +@[simp] theorem leibniz (a b : B) : D (a * b) = a * D b + D a * b := D.leibniz' a b + +lemma map_nsmul (a : B) (n : ℕ) : D (n • a) = n • D a := by + induction n with + | zero => simp + | succ n ih => simp only [succ_nsmul, map_add, ih] + +end OreDivisionDerivation + +namespace OreDivision + +variable {B : Type*} [Ring B] (D : OreDivisionDerivation B) + +/-- The coefficient-left normal form of `x^i*b` under `x*b=b*x+D(b)`. -/ +def push (b : B) (i : ℕ) : Polynomial B := + ∑ k ∈ Finset.range (i + 1), + Polynomial.monomial (i - k) (Nat.choose i k • (D^[k]) b) + +lemma push_coeff (b : B) (i n : ℕ) : + (OreDivision.push D b i).coeff n = + ∑ k ∈ Finset.range (i + 1), + if i - k = n then Nat.choose i k • (D^[k]) b else 0 := by + simp [push, Polynomial.coeff_sum, Polynomial.coeff_monomial] + +lemma push_degree_le (b : B) (i : ℕ) : (OreDivision.push D b i).degree ≤ (i : WithBot ℕ) := by + rw [Polynomial.degree_le_iff_coeff_zero] + intro n hn + rw [push_coeff] + apply Finset.sum_eq_zero + intro k hk + by_cases hki : i - k = n + · have hn' : i < n := by exact_mod_cast hn + have hle : i - k ≤ i := Nat.sub_le _ _ + omega + · simp [hki] + +lemma push_coeff_top (b : B) (i : ℕ) : (OreDivision.push D b i).coeff i = b := by + rw [push_coeff] + rw [Finset.sum_eq_single 0 (by + intro k hk hk0 + have hkpos : 0 < k := Nat.pos_of_ne_zero hk0 + have hk_lt : k < i + 1 := Finset.mem_range.mp hk + have hk_le : k ≤ i := by omega + have hi_pos : 0 < i := lt_of_lt_of_le hkpos hk_le + have hki : i - k ≠ i := Nat.ne_of_lt (Nat.sub_lt hi_pos hkpos) + simp [hki]) (by simp)] + simp + +lemma push_eq_zero_of (b : B) (i : ℕ) (h : b = 0) : OreDivision.push D b i = 0 := by + subst b + have hiter : ∀ n : ℕ, (D^[n]) 0 = 0 := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply'] + simp [ih, OreDivisionDerivation.map_zero] + simp [push, hiter] + +/-- Right multiplication of a normal polynomial by the monomial `b*x^j`. + +The definition is coefficientwise and finite. It is deliberately not the +ordinary multiplication of `Polynomial B`: the inner `push` expansion is the +derivation correction for moving `b` through powers of `x`. +-/ +def rightTerm (i : ℕ) (a b : B) (j : ℕ) : Polynomial B := + ∑ k ∈ Finset.range (i + 1), + Polynomial.monomial (i - k + j) + (a * (Nat.choose i k • (D^[k]) b)) + +/-- Right multiplication by one coefficient-monomial. -/ +def rightMulMonomial (p : Polynomial B) (b : B) (j : ℕ) : Polynomial B := + p.sum (fun i a => rightTerm D i a b j) + +lemma rightMulMonomial_coeff (p : Polynomial B) (b : B) (j n : ℕ) : + (rightMulMonomial D p b j).coeff n = + ∑ i ∈ p.support, ∑ k ∈ Finset.range (i + 1), + if i - k + j = n then + p.coeff i * (Nat.choose i k • (D^[k]) b) else 0 := by + simp [rightMulMonomial, rightTerm, Polynomial.coeff_sum, + Polynomial.coeff_monomial, Polynomial.sum_def] + +lemma rightTerm_zero (i : ℕ) (b : B) (j : ℕ) : rightTerm D i 0 b j = 0 := by + simp [rightTerm] + +lemma rightTerm_add_left (i : ℕ) (a₁ a₂ b : B) (j : ℕ) : + rightTerm D i (a₁ + a₂) b j = + rightTerm D i a₁ b j + rightTerm D i a₂ b j := by + simp only [rightTerm, add_mul] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro k hk + rw [map_add] + +lemma rightMulMonomial_add_left (p q : Polynomial B) (b : B) (j : ℕ) : + rightMulMonomial D (p + q) b j = + rightMulMonomial D p b j + rightMulMonomial D q b j := by + apply Polynomial.sum_add_index + · intro i + exact rightTerm_zero D i b j + · intro i a₁ a₂ + exact rightTerm_add_left D i a₁ a₂ b j + +lemma iterate_add (n : ℕ) (b₁ b₂ : B) : + (D^[n]) (b₁ + b₂) = (D^[n]) b₁ + (D^[n]) b₂ := by + induction n with + | zero => simp + | succ n ih => + calc + (D^[n + 1]) (b₁ + b₂) = D ((D^[n]) (b₁ + b₂)) := + Function.iterate_succ_apply' D n (b₁ + b₂) + _ = D ((D^[n]) b₁ + (D^[n]) b₂) := by rw [ih] + _ = D ((D^[n]) b₁) + D ((D^[n]) b₂) := D.map_add _ _ + _ = (D^[n + 1]) b₁ + (D^[n + 1]) b₂ := by + rw [Function.iterate_succ_apply', Function.iterate_succ_apply'] + +lemma iterate_zero (n : ℕ) : (D^[n]) 0 = 0 := by + induction n with + | zero => simp + | succ n ih => + calc + (D^[n + 1]) 0 = D ((D^[n]) 0) := Function.iterate_succ_apply' D n 0 + _ = D 0 := by rw [ih] + _ = 0 := D.map_zero + +lemma rightMulMonomial_add_right (p : Polynomial B) (b₁ b₂ : B) (j : ℕ) : + rightMulMonomial D p (b₁ + b₂) j = + rightMulMonomial D p b₁ j + rightMulMonomial D p b₂ j := by + apply Polynomial.ext + intro n + rw [rightMulMonomial_coeff, Polynomial.coeff_add, + rightMulMonomial_coeff, rightMulMonomial_coeff] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro k hk + by_cases hEq : i - k + j = n + · simp only [if_pos hEq, iterate_add, nsmul_add, mul_add] + · simp [hEq] + +lemma rightMulMonomial_zero_right (p : Polynomial B) (j : ℕ) : + rightMulMonomial D p 0 j = 0 := by + apply Polynomial.ext + intro n + rw [rightMulMonomial_coeff] + apply Finset.sum_eq_zero + intro i hi + apply Finset.sum_eq_zero + intro k hk + simp [iterate_zero] + +/-- The product `d*q` of a normal polynomial by a normal right quotient. -/ +def rightMul (d q : Polynomial B) : Polynomial B := + q.sum (fun j c => rightMulMonomial D d c j) + +lemma rightMul_add (d q₁ q₂ : Polynomial B) : + rightMul D d (q₁ + q₂) = rightMul D d q₁ + rightMul D d q₂ := by + apply Polynomial.sum_add_index + · intro j + exact rightMulMonomial_zero_right D d j + · intro j c₁ c₂ + exact rightMulMonomial_add_right D d c₁ c₂ j + +lemma rightMul_zero (d : Polynomial B) : rightMul D d 0 = 0 := by + simp [rightMul, Polynomial.sum_def] + +/-- The additive map given by right multiplication by a fixed normal form. -/ +def rightMulAddHom (d : Polynomial B) : Polynomial B →+ Polynomial B where + toFun := rightMul D d + map_zero' := rightMul_zero D d + map_add' := rightMul_add D d + +lemma rightMul_sub (d q₁ q₂ : Polynomial B) : + rightMul D d (q₁ - q₂) = rightMul D d q₁ - rightMul D d q₂ := by + exact map_sub (rightMulAddHom D d) q₁ q₂ + +lemma rightMul_monomial (d : Polynomial B) (c : B) (j : ℕ) : + rightMul D d (Polynomial.monomial j c) = + rightMulMonomial D d c j := by + by_cases hc : c = 0 + · subst c + simp [rightMul, Polynomial.sum_def, rightMulMonomial_zero_right] + · unfold rightMul + rw [Polynomial.sum_def, Polynomial.support_monomial j hc] + simp [Polynomial.coeff_monomial, hc] + +lemma rightMulMonomial_degree_le (p : Polynomial B) (b : B) (j : ℕ) : + (rightMulMonomial D p b j).degree ≤ (p.natDegree + j : WithBot ℕ) := by + rw [Polynomial.degree_le_iff_coeff_zero] + intro n hn + rw [rightMulMonomial_coeff] + apply Finset.sum_eq_zero + intro i hi + apply Finset.sum_eq_zero + intro k hk + by_cases hEq : i - k + j = n + · have hn' : p.natDegree + j < n := by exact_mod_cast hn + have hi_le : i ≤ p.natDegree := Polynomial.le_natDegree_of_mem_supp i hi + have hle : i - k + j ≤ p.natDegree + j := by + omega + omega + · simp [hEq] + +lemma rightMulMonomial_coeff_top (p : Polynomial B) (hp : p ≠ 0) + (b : B) (j : ℕ) : + (rightMulMonomial D p b j).coeff (p.natDegree + j) = + p.leadingCoeff * b := by + rw [rightMulMonomial_coeff] + have htop : p.natDegree ∈ p.support := + Polynomial.natDegree_mem_support_of_nonzero hp + rw [Finset.sum_eq_single p.natDegree (by + intro i hi hne + apply Finset.sum_eq_zero + intro k hk + have hi_le : i ≤ p.natDegree := Polynomial.le_natDegree_of_mem_supp i hi + have hi_lt : i < p.natDegree := lt_of_le_of_ne hi_le hne + have hne_sub : i - k ≠ p.natDegree := by omega + simp [hne_sub]) (by simp [htop])] + rw [Finset.sum_eq_single 0 (by + intro k hk hk0 + have hkpos : 0 < k := Nat.pos_of_ne_zero hk0 + have hk_lt : k < p.natDegree + 1 := Finset.mem_range.mp hk + have hk_le : k ≤ p.natDegree := by omega + have hNpos : 0 < p.natDegree := lt_of_lt_of_le hkpos hk_le + have hne_sub : p.natDegree - k ≠ p.natDegree := + Nat.ne_of_lt (Nat.sub_lt hNpos hkpos) + simp [hne_sub]) (by simp)] + rw [Nat.sub_zero] + simp only [if_true, Nat.choose_zero_right, Function.iterate_zero_apply, + one_nsmul, one_mul, Polynomial.leadingCoeff] + +lemma rightMul_degree_le (d q : Polynomial B) : + (rightMul D d q).degree ≤ (d.natDegree + q.natDegree : WithBot ℕ) := by + rw [Polynomial.degree_le_iff_coeff_zero] + intro n hn + rw [rightMul, Polynomial.coeff_sum] + apply Finset.sum_eq_zero + intro j hj + apply Polynomial.coeff_eq_zero_of_degree_lt + have hj_le : j ≤ q.natDegree := Polynomial.le_natDegree_of_mem_supp j hj + have hdeg : (rightMulMonomial D d (q.coeff j) j).degree ≤ + (d.natDegree + j : WithBot ℕ) := + rightMulMonomial_degree_le D d (q.coeff j) j + have hbound : (d.natDegree + j : WithBot ℕ) ≤ + (d.natDegree + q.natDegree : WithBot ℕ) := by + exact_mod_cast Nat.add_le_add_left hj_le d.natDegree + exact lt_of_le_of_lt hdeg (lt_of_le_of_lt hbound hn) + +lemma rightMul_coeff_top [Nontrivial B] (d q : Polynomial B) + (hd : d.Monic) (hq : q ≠ 0) : + (rightMul D d q).coeff (d.natDegree + q.natDegree) = q.leadingCoeff := by + rw [rightMul, Polynomial.coeff_sum] + rw [Polynomial.sum_def] + have hqtop : q.natDegree ∈ q.support := + Polynomial.natDegree_mem_support_of_nonzero hq + rw [Finset.sum_eq_single q.natDegree (by + intro j hj hne + have hj_le : j ≤ q.natDegree := Polynomial.le_natDegree_of_mem_supp j hj + have hj_lt : j < q.natDegree := lt_of_le_of_ne hj_le hne + have hdeg : (rightMulMonomial D d (q.coeff j) j).degree ≤ + (d.natDegree + j : WithBot ℕ) := + rightMulMonomial_degree_le D d (q.coeff j) j + have hlt : (d.natDegree + j : WithBot ℕ) < + (d.natDegree + q.natDegree : WithBot ℕ) := by + exact_mod_cast Nat.add_lt_add_left hj_lt d.natDegree + have hzero : (rightMulMonomial D d (q.coeff j) j).coeff + (d.natDegree + q.natDegree) = 0 := + Polynomial.coeff_eq_zero_of_degree_lt (lt_of_le_of_lt hdeg hlt) + exact hzero) (by simp [hqtop])] + have hd0 : d ≠ 0 := hd.ne_zero + rw [rightMulMonomial_coeff_top D d hd0 (q.coeff q.natDegree) q.natDegree, + hd.leadingCoeff, one_mul] + rfl + +lemma rightMul_degree_eq [Nontrivial B] (d q : Polynomial B) + (hd : d.Monic) (hq : q ≠ 0) : + (rightMul D d q).degree = (d.natDegree + q.natDegree : WithBot ℕ) := by + have hle := rightMul_degree_le D d q + have htop : (rightMul D d q).coeff (d.natDegree + q.natDegree) = + q.leadingCoeff := rightMul_coeff_top D d q hd hq + have hq0 : q.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hq + have hge : (d.natDegree + q.natDegree : WithBot ℕ) ≤ + (rightMul D d q).degree := by + by_contra hnot + have hlt0 : (rightMul D d q).degree < + (d.natDegree + q.natDegree : WithBot ℕ) := lt_of_not_ge hnot + have hlt : (rightMul D d q).degree < + ((d.natDegree + q.natDegree : ℕ) : WithBot ℕ) := by + have heq : (d.natDegree + q.natDegree : WithBot ℕ) = + ((d.natDegree + q.natDegree : ℕ) : WithBot ℕ) := + (WithBot.coe_add d.natDegree q.natDegree).symm + rwa [heq] at hlt0 + have hz := Polynomial.coeff_eq_zero_of_degree_lt hlt + exact hq0 (by rw [← htop, hz]) + exact le_antisymm hle hge + +theorem rightMul_injective [Nontrivial B] (d : Polynomial B) (hd : d.Monic) : + Function.Injective (rightMul D d) := by + intro q₁ q₂ hq + by_contra hne + have hdiff : q₁ - q₂ ≠ 0 := sub_ne_zero.mpr hne + have hz : rightMul D d (q₁ - q₂) = 0 := by + rw [rightMul_sub, hq, sub_self] + have hdeg := rightMul_degree_eq D d (q₁ - q₂) hd hdiff + rw [hz] at hdeg + have hne : (⊥ : WithBot ℕ) ≠ + (d.natDegree + (q₁ - q₂).natDegree : WithBot ℕ) := by + have heq : (d.natDegree + (q₁ - q₂).natDegree : WithBot ℕ) = + ((d.natDegree + (q₁ - q₂).natDegree : ℕ) : WithBot ℕ) := + (WithBot.coe_add d.natDegree (q₁ - q₂).natDegree).symm + rw [heq] + exact WithBot.bot_ne_coe + exact hne hdeg + +/-! The leading-degree theorem packages the strict filtered-intersection +property needed by the relative principal-source construction. This is an +Ore-polynomial filtration statement; it is deliberately not identified here +with the Bernstein filtration on the Weyl algebra. -/ + +theorem rightMul_degree_le_iff [Nontrivial B] (d q : Polynomial B) + (hd : d.Monic) (n : ℕ) : + (rightMul D d q).degree ≤ (n : WithBot ℕ) ↔ + q = 0 ∨ d.natDegree + q.natDegree ≤ n := by + constructor + · intro h + by_cases hq : q = 0 + · exact Or.inl hq + · right + have hdeg := rightMul_degree_eq D d q hd hq + rw [hdeg] at h + exact_mod_cast h + · intro h + rcases h with hzero | hq + · subst q + simp [rightMul_zero] + · by_cases hq0 : q = 0 + · subst q + simp [rightMul_zero] + · have hdeg := rightMul_degree_eq D d q hd hq0 + rw [hdeg] + exact_mod_cast hq + +lemma remainder_degree_lt (d r : Polynomial B) + (hr : r = 0 ∨ r.natDegree < d.natDegree) : + r.degree < (d.natDegree : WithBot ℕ) := by + rcases hr with rfl | hr + · exact WithBot.bot_lt_coe _ + · by_cases hr0 : r = 0 + · subst r + exact WithBot.bot_lt_coe _ + · rw [Polynomial.degree_eq_natDegree hr0] + exact_mod_cast hr + +theorem right_division_unique [Nontrivial B] (d p q₁ q₂ r₁ r₂ : Polynomial B) + (hd : d.Monic) + (h₁ : p = rightMul D d q₁ + r₁) + (h₂ : p = rightMul D d q₂ + r₂) + (hr₁ : r₁ = 0 ∨ r₁.natDegree < d.natDegree) + (hr₂ : r₂ = 0 ∨ r₂.natDegree < d.natDegree) : + q₁ = q₂ ∧ r₁ = r₂ := by + have heq : rightMul D d q₁ + r₁ = rightMul D d q₂ + r₂ := + h₁.symm.trans h₂ + have hrel : rightMul D d (q₁ - q₂) = r₂ - r₁ := by + rw [rightMul_sub] + apply (sub_eq_iff_eq_add).2 + calc + rightMul D d q₁ = + (rightMul D d q₂ + r₂) - r₁ := + (eq_sub_iff_add_eq).2 heq + _ = (r₂ - r₁) + rightMul D d q₂ := by abel + have hrdiff : (r₂ - r₁).degree < (d.natDegree : WithBot ℕ) := by + have h₁deg := remainder_degree_lt d r₁ hr₁ + have h₂deg := remainder_degree_lt d r₂ hr₂ + exact lt_of_le_of_lt (Polynomial.degree_sub_le r₂ r₁) (max_lt h₂deg h₁deg) + have hqeq : q₁ = q₂ := by + by_contra hne + have hdiff : q₁ - q₂ ≠ 0 := sub_ne_zero.mpr hne + have hleft := rightMul_degree_eq D d (q₁ - q₂) hd hdiff + have hleft_ge : (d.natDegree : WithBot ℕ) ≤ + (rightMul D d (q₁ - q₂)).degree := by + rw [hleft] + apply le_add_of_nonneg_right + exact_mod_cast (Nat.zero_le (q₁ - q₂).natDegree) + have hright_ge : (d.natDegree : WithBot ℕ) ≤ (r₂ - r₁).degree := by + rw [← hrel] + exact hleft_ge + exact (not_le_of_gt hrdiff) hright_ge + have hrEq : r₁ = r₂ := by + apply add_left_cancel (b := r₁) (a := rightMul D d q₂) + simpa [hqeq] using heq + exact ⟨hqeq, hrEq⟩ + +lemma cancel_degree_lt [Nontrivial B] (d p : Polynomial B) (hd : d.Monic) + (hp : p ≠ 0) (hdeg : d.natDegree ≤ p.natDegree) : + (p - rightMulMonomial D d p.leadingCoeff + (p.natDegree - d.natDegree)).degree < p.degree := by + let c : B := p.leadingCoeff + let j : ℕ := p.natDegree - d.natDegree + let q : Polynomial B := rightMulMonomial D d c j + have hd0 : d ≠ 0 := hd.ne_zero + have hc0 : c ≠ 0 := by + dsimp [c] + exact Polynomial.leadingCoeff_ne_zero.mpr hp + have hsum : d.natDegree + j = p.natDegree := by + dsimp [j] + exact Nat.add_sub_of_le hdeg + have hq_le : q.degree ≤ (p.natDegree : WithBot ℕ) := by + dsimp [q, c, j] + have h := rightMulMonomial_degree_le D d p.leadingCoeff + (p.natDegree - d.natDegree) + have hcast : (d.natDegree : WithBot ℕ) + + (p.natDegree - d.natDegree : WithBot ℕ) = + (p.natDegree : WithBot ℕ) := by + exact_mod_cast (Nat.add_sub_of_le hdeg) + rw [hcast] at h + exact h + have hq_top : q.coeff p.natDegree = c := by + dsimp [q] + rw [← hsum, + rightMulMonomial_coeff_top D d hd0 c j, hd.leadingCoeff, one_mul] + have hq0 : q ≠ 0 := by + intro hqzero + have hz := congrArg (fun z : Polynomial B => z.coeff p.natDegree) hqzero + change q.coeff p.natDegree = 0 at hz + rw [hq_top] at hz + exact hc0 hz + have hq_ge : (p.natDegree : WithBot ℕ) ≤ q.degree := by + by_contra hnot + have hlt : q.degree < (p.natDegree : WithBot ℕ) := lt_of_not_ge hnot + have hz : q.coeff p.natDegree = 0 := + Polynomial.coeff_eq_zero_of_degree_lt hlt + exact hc0 (by rw [← hq_top, hz]) + have hq_degree : q.degree = (p.natDegree : WithBot ℕ) := + le_antisymm hq_le hq_ge + have hp_degree : p.degree = (p.natDegree : WithBot ℕ) := + Polynomial.degree_eq_natDegree hp + have hleading : p.leadingCoeff = q.leadingCoeff := by + change p.coeff p.natDegree = q.coeff q.natDegree + have hq_nat : q.natDegree = p.natDegree := by + have hq_degree_nat : (q.natDegree : WithBot ℕ) = + (p.natDegree : WithBot ℕ) := by + rw [← Polynomial.degree_eq_natDegree hq0] + exact hq_degree + exact_mod_cast hq_degree_nat + rw [hq_nat, hq_top] + rfl + exact Polynomial.degree_sub_lt (hp_degree.trans hq_degree.symm) hp hleading + +theorem right_division_exists [Nontrivial B] (d p : Polynomial B) (hd : d.Monic) : + ∃ q r : Polynomial B, + p = rightMul D d q + r ∧ (r = 0 ∨ r.natDegree < d.natDegree) := by + let P : ℕ → Prop := fun n => + ∀ p : Polynomial B, p.natDegree = n → + ∃ q r : Polynomial B, + p = rightMul D d q + r ∧ (r = 0 ∨ r.natDegree < d.natDegree) + have hall : P p.natDegree := by + refine Nat.strong_induction_on p.natDegree ?_ + intro n ih + dsimp [P] + intro p hpN + by_cases hp0 : p = 0 + · subst p + exact ⟨0, 0, by simp [rightMul], Or.inl rfl⟩ + by_cases hsmall : p.natDegree < d.natDegree + · exact ⟨0, p, by simp [rightMul], Or.inr hsmall⟩ + · have hlarge : d.natDegree ≤ p.natDegree := Nat.le_of_not_gt hsmall + let c : B := p.leadingCoeff + let j : ℕ := p.natDegree - d.natDegree + let rm : Polynomial B := rightMulMonomial D d c j + have hcancel : (p - rm).degree < p.degree := by + dsimp [rm, c, j] + exact cancel_degree_lt D d p hd hp0 hlarge + by_cases hrem0 : p - rm = 0 + · refine ⟨Polynomial.monomial j c, 0, ?_, Or.inl rfl⟩ + rw [rightMul_monomial] + dsimp [rm] at hrem0 ⊢ + simpa [add_zero] using (sub_eq_zero.mp hrem0) + · have hremN : (p - rm).natDegree < p.natDegree := + Polynomial.natDegree_lt_natDegree hrem0 hcancel + have hremN' : (p - rm).natDegree < n := by + rw [← hpN] + exact hremN + obtain ⟨q, r, hqr, hrr⟩ := + ih (p - rm).natDegree hremN' (p - rm) rfl + refine ⟨Polynomial.monomial j c + q, r, ?_, hrr⟩ + calc + p = rm + (p - rm) := by abel + _ = rm + (rightMul D d q + r) := by rw [hqr] + _ = rightMul D d (Polynomial.monomial j c + q) + r := by + rw [rightMul_add, rightMul_monomial] + dsimp [rm] + abel + dsimp [P] at hall + exact hall p rfl + +/-- An ambient ring in which the Ore relation is represented. -/ +structure OreAmbient (B A : Type*) [Ring B] [Ring A] + (D : OreDivisionDerivation B) where + /-- The coefficient-ring embedding. -/ + embed : B →+* A + /-- The element representing the Ore variable. -/ + x : A + /-- The defining relation in the ambient ring. -/ + relation : ∀ b, x * embed b = embed b * x + embed (D b) + +namespace OreAmbient + +variable {B A : Type*} [Ring B] [Ring A] + (D : OreDivisionDerivation B) (O : OreAmbient B A D) + +/-- The inner derivation `a ↦ p*a-a*p`, used to formalize the iterated +commutator expansion of a power of `p`. -/ +def commutatorDerivation (p : A) : OreDivisionDerivation A where + toFun a := p * a - a * p + map_zero' := by simp + map_add' a b := by noncomm_ring + leibniz' a b := by noncomm_ring + +/-- The ambient Ore presentation for an inner derivation. -/ +def commutatorAmbient (p : A) : + OreAmbient A A (commutatorDerivation p) where + embed := RingHom.id A + x := p + relation := by + intro a + change p * a = a * p + (p * a - a * p) + noncomm_ring + +/-- A term in the iterated commutator expansion. -/ +def term (b : B) (i j : ℕ) : A := + O.embed ((D^[i]) b) * O.x ^ j + +lemma push_term (b : B) (i j : ℕ) : + O.x * term D O b i j = term D O b i (j + 1) + term D O b (i + 1) j := by + dsimp [term] + calc + O.x * (O.embed ((D^[i]) b) * O.x ^ j) = + (O.x * O.embed ((D^[i]) b)) * O.x ^ j := by rw [mul_assoc] + _ = (O.embed ((D^[i]) b) * O.x + + O.embed (D ((D^[i]) b))) * O.x ^ j := by rw [O.relation] + _ = O.embed ((D^[i]) b) * O.x ^ (j + 1) + + O.embed ((D^[i + 1]) b) * O.x ^ j := by + rw [add_mul, mul_assoc, ← pow_succ', Function.iterate_succ_apply'] + +lemma mul_nsmul_left (a u : A) (n : ℕ) : + a * (n • u) = n • (a * u) := by + induction n with + | zero => simp + | succ n ih => simp only [succ_nsmul, mul_add, ih] + +lemma nsmul_mul_right (a u : A) (n : ℕ) : + (n • a) * u = n • (a * u) := by + induction n with + | zero => simp + | succ n ih => simp only [succ_nsmul, add_mul, ih] + +/-- The normal-order expansion of `x^n * embed b`. -/ +def expansion (b : B) (n : ℕ) : A := + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • term D O b ij.1 ij.2 + +theorem pow_mul (b : B) (n : ℕ) : + O.x ^ n * O.embed b = expansion D O b n := by + induction n with + | zero => + simp [expansion, term] + | succ n ih => + rw [pow_succ', mul_assoc, ih, expansion, Finset.mul_sum] + simp_rw [mul_nsmul_left O.x, O.push_term, smul_add] + rw [Finset.sum_add_distrib, expansion] + rw [Finset.sum_antidiagonal_choose_succ_nsmul] + have hsecond : + (∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • term D O b (ij.1 + 1) ij.2) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.2 • term D O b (ij.1 + 1) ij.2 := by + apply Finset.sum_congr rfl + intro ij hij + have hsum : ij.1 + ij.2 = n := + Finset.HasAntidiagonal.mem_antidiagonal.mp hij + have hi : ij.1 ≤ n := by omega + rw [← Nat.choose_symm hi] + rw [show n - ij.1 = ij.2 by omega] + rw [hsecond] + +/-- A single coefficient moved through a power of the Ore variable. -/ +def reverseTerm (b : B) (i j : ℕ) : A := + O.x ^ j * O.embed ((D^[i]) b) + +/-- A signed term for the reverse normal-order expansion. -/ +def reverseSignedTerm (b : B) (i j : ℕ) : A := + (-1 : A) ^ i * reverseTerm D O b i j + +/-- The reverse normal-order expansion of `x^n * embed b`. -/ +def reverseExpansion (b : B) (n : ℕ) : A := + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • reverseSignedTerm D O b ij.1 ij.2 + +lemma reverseTerm_mul (b : B) (i j : ℕ) : + reverseTerm D O b i j * O.x = + reverseTerm D O b i (j + 1) - reverseTerm D O b (i + 1) j := by + dsimp [reverseTerm] + have hmove : O.embed ((D^[i]) b) * O.x = + O.x * O.embed ((D^[i]) b) - O.embed (D ((D^[i]) b)) := by + rw [O.relation] + noncomm_ring + rw [show O.x ^ j * O.embed ((D^[i]) b) * O.x = + O.x ^ j * (O.embed ((D^[i]) b) * O.x) by rw [mul_assoc], hmove, + mul_sub, pow_succ'] + rw [← mul_assoc, ← pow_succ, pow_succ'] + rw [← Function.iterate_succ_apply' D i b, + ← Function.iterate_succ_apply D i b] + +lemma reverseSignedTerm_mul (b : B) (i j : ℕ) : + reverseSignedTerm D O b i j * O.x = + reverseSignedTerm D O b i (j + 1) + + reverseSignedTerm D O b (i + 1) j := by + dsimp [reverseSignedTerm] + rw [mul_assoc, reverseTerm_mul, mul_sub, pow_succ'] + noncomm_ring + +theorem reverse_mul (b : B) (n : ℕ) : + O.embed b * O.x ^ n = reverseExpansion D O b n := by + induction n with + | zero => + simp [reverseExpansion, reverseSignedTerm, reverseTerm] + | succ n ih => + rw [pow_succ, ← mul_assoc, ih, reverseExpansion, Finset.sum_mul] + simp_rw [nsmul_mul_right, reverseSignedTerm_mul] + simp_rw [nsmul_add] + unfold reverseExpansion + have hsecond : + (∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • reverseSignedTerm D O b (ij.1 + 1) ij.2) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.2 • reverseSignedTerm D O b (ij.1 + 1) ij.2 := by + apply Finset.sum_congr rfl + intro ij hij + have hsum : ij.1 + ij.2 = n := + Finset.HasAntidiagonal.mem_antidiagonal.mp hij + have hi : ij.1 ≤ n := by omega + rw [← Nat.choose_symm hi] + rw [show n - ij.1 = ij.2 by omega] + rw [Finset.sum_add_distrib, hsecond] + exact (Finset.sum_antidiagonal_choose_succ_nsmul + (fun i j => reverseSignedTerm D O b i j) n).symm + +theorem commutator_pow_mul (p a : A) (m : ℕ) : + p ^ m * a = + OreAmbient.expansion (commutatorDerivation p) (commutatorAmbient p) a m := by + exact OreAmbient.pow_mul (commutatorDerivation p) (commutatorAmbient p) a m + +theorem commutator_pow_mul_explicit (p a : A) (m : ℕ) : + p ^ m * a = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal m, + m.choose ij.1 • (((commutatorDerivation p)^[ij.1]) a * p ^ ij.2) := by + simpa [OreAmbient.expansion, term, commutatorAmbient] using + (commutator_pow_mul (A := A) p a m) + +theorem commutator_pow_succ (p x : A) + (hpx : p * x - x * p = 1) (r : ℕ) : + p * x ^ (r + 1) - x ^ (r + 1) * p = (r + 1) • x ^ r := by + induction r with + | zero => simpa using hpx + | succ r ih => + calc + p * x ^ (r + 1 + 1) - x ^ (r + 1 + 1) * p = + (p * x ^ (r + 1) - x ^ (r + 1) * p) * x + + x ^ (r + 1) * (p * x - x * p) := by + noncomm_ring + _ = ((r + 1) • x ^ r) * x + x ^ (r + 1) * 1 := by rw [ih, hpx] + _ = (r + 2) • x ^ (r + 1) := by + rw [mul_one, nsmul_mul_right, pow_succ'] + have hpow : x ^ r * x = x * x ^ r := by + rw [← pow_succ, pow_succ'] + rw [hpow] + simp only [succ_nsmul] + +theorem commutator_iterate_pow_of_le (p x : A) + (hpx : p * x - x * p = 1) (j n : ℕ) (hjn : j ≤ n) : + (((commutatorDerivation p)^[j]) (x ^ n)) = + n.descFactorial j • x ^ (n - j) := by + induction j generalizing n with + | zero => simp + | succ j ih => + have hjn' : j ≤ n := by omega + rw [Function.iterate_succ_apply', ih n hjn'] + have hpow : x ^ (n - j) = x ^ ((n - j - 1) + 1) := by + congr 1 + omega + have hcomm : + (commutatorDerivation p) (x ^ (n - j)) = + (n - j) • x ^ (n - j - 1) := by + change p * x ^ (n - j) - x ^ (n - j) * p = _ + rw [hpow] + have hsub : n - j - 1 + 1 = n - j := by omega + simpa only [hsub] using commutator_pow_succ p x hpx (n - j - 1) + rw [OreDivisionDerivation.map_nsmul, hcomm, smul_smul, + Nat.descFactorial_succ] + rw [show n - (j + 1) = n - j - 1 by omega, Nat.mul_comm] + +theorem commutator_iterate_pow_of_lt (p x : A) + (hpx : p * x - x * p = 1) (j n : ℕ) (hnj : n < j) : + (((commutatorDerivation p)^[j]) (x ^ n)) = 0 := by + induction j with + | zero => omega + | succ j ih => + by_cases hj : n < j + · rw [Function.iterate_succ_apply', ih hj] + simp [commutatorDerivation] + · have hjeq : j = n := by omega + rw [Function.iterate_succ_apply', hjeq, + commutator_iterate_pow_of_le p x hpx n n le_rfl] + simp [commutatorDerivation] + rw [Nat.cast_comm] + simp + +theorem commutator_iterate_pow (p x : A) + (hpx : p * x - x * p = 1) (j n : ℕ) : + (((commutatorDerivation p)^[j]) (x ^ n)) = + if j ≤ n then n.descFactorial j • x ^ (n - j) else 0 := by + by_cases hjn : j ≤ n + · simp [hjn, commutator_iterate_pow_of_le p x hpx j n hjn] + · have hnj : n < j := Nat.lt_of_not_ge hjn + simp [hjn, commutator_iterate_pow_of_lt p x hpx j n hnj] + +theorem commutator_pow_mul_pow (p x : A) + (hpx : p * x - x * p = 1) (k r : ℕ) : + p ^ k * x ^ r = + ∑ i ∈ Finset.range (k + 1), + if i ≤ r then + (k.choose i * r.descFactorial i) • + (x ^ (r - i) * p ^ (k - i)) + else 0 := by + rw [commutator_pow_mul_explicit] + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ + (fun i j => k.choose i • + (((commutatorDerivation p)^[i]) (x ^ r) * p ^ j)) k] + apply Finset.sum_congr rfl + intro i hi + by_cases hir : i ≤ r + · rw [commutator_iterate_pow p x hpx i r] + simp only [if_pos hir] + rw [show k - i = (k - i) by rfl] + simp [hir, smul_mul_assoc, smul_smul, Nat.mul_comm, Nat.mul_left_comm, + Nat.mul_assoc, mul_assoc] + · rw [commutator_iterate_pow p x hpx i r] + simp [hir] + +/-! ### p-free monic corner + +The quotient by the image of right multiplication by `p` keeps only the +p-free term of the normal-ordering expansion. The following theorem isolates +the monic contribution; lower coefficient terms are handled by the separate +Newton arithmetic lemmas in `a2_newton_bound.lean`. +-/ + +/-- The linear map given by right multiplication by `p`. -/ +def pRightMulLinear {k A : Type*} [Field k] [Ring A] [Algebra k A] + (p : A) : A →ₗ[k] A where + toFun z := z * p + map_add' x y := by + change (x + y) * p = x * p + y * p + rw [add_mul] + map_smul' c x := by + simp only [Algebra.smul_def, RingHom.id_apply] + rw [mul_assoc] + +/-- The range of right multiplication by `p`. -/ +def pRightMulRange {k A : Type*} [Field k] [Ring A] [Algebra k A] + (p : A) : Submodule k A := + LinearMap.range (pRightMulLinear p) + +lemma pRightMulRange_mem_of_mul_p {k A : Type*} [Field k] [Ring A] + [Algebra k A] (p z : A) : z * p ∈ pRightMulRange (k := k) p := by + exact ⟨z, rfl⟩ + +theorem pfree_power_of_le {k A : Type*} [Field k] [Ring A] + [Algebra k A] (p x : A) (hpx : p * x - x * p = 1) + (u n : ℕ) (hun : u ≤ n) : + Submodule.mkQ (pRightMulRange (k := k) p) (p ^ u * x ^ n) = + (n.descFactorial u : k) • + Submodule.mkQ (pRightMulRange (k := k) p) (x ^ (n - u)) := by + rw [commutator_pow_mul_pow p x hpx u n] + rw [map_sum] + rw [Finset.sum_eq_single u] + · simp only [hun, ↓reduceIte, Nat.choose_self, Nat.cast_one, one_mul, + Nat.cast_ofNat, nsmul_eq_mul, map_smul, Nat.sub_self, pow_zero, mul_one] + change Submodule.Quotient.mk + (↑(n.descFactorial u) * x ^ (n - u)) = + (n.descFactorial u : k) • Submodule.Quotient.mk (x ^ (n - u)) + rw [← Submodule.Quotient.mk_smul] + congr 1 + simp [Algebra.smul_def] + · intro i hi hik + simp only [Finset.mem_range] at hi + have hlt : i < u := by omega + have hpow : p ^ (u - i) = p ^ (u - i - 1) * p := by + calc + p ^ (u - i) = p ^ ((u - i - 1) + 1) := by congr 1; omega + _ = p ^ (u - i - 1) * p := by rw [pow_succ] + have hmem : x ^ (n - i) * p ^ (u - i) ∈ + pRightMulRange (k := k) p := by + rw [hpow] + simpa [mul_assoc] using + (pRightMulRange_mem_of_mul_p (k := k) p + (x ^ (n - i) * p ^ (u - i - 1))) + have hzero : Submodule.mkQ (pRightMulRange (k := k) p) + (x ^ (n - i) * p ^ (u - i)) = 0 := + (Submodule.Quotient.mk_eq_zero (pRightMulRange (k := k) p)).2 hmem + simp only [if_pos (by omega : i ≤ n), map_nsmul, hzero, smul_zero] + · simp + +theorem pfree_monic_corner {k A : Type*} [Field k] [Ring A] + [Algebra k A] (p x : A) (hpx : p * x - x * p = 1) + (m r : ℕ) : + Submodule.mkQ (pRightMulRange (k := k) p) (p ^ m * x ^ (m + r)) = + (Nat.choose m m * (m + r).descFactorial m : k) • + Submodule.mkQ (pRightMulRange (k := k) p) (x ^ r) := by + rw [commutator_pow_mul_pow p x hpx m (m + r)] + rw [map_sum] + rw [Finset.sum_eq_single m] + · simp only [Nat.choose_self, Nat.le_add_right, ↓reduceIte, Nat.sub_self, + Nat.cast_one, one_mul, Nat.cast_ofNat, nsmul_eq_mul, map_smul] + simp only [Submodule.mkQ_apply, pow_zero, Nat.add_sub_cancel_left, mul_one] + rw [← Submodule.Quotient.mk_smul] + congr 1 + simp [Algebra.smul_def] + · intro i hi him + simp only [Finset.mem_range] at hi + have hpos : 0 < m - i := by omega + have hpow : p ^ (m - i) = p ^ (m - i - 1) * p := by + calc + p ^ (m - i) = p ^ ((m - i - 1) + 1) := by congr 1; omega + _ = p ^ (m - i - 1) * p := by rw [pow_succ] + have hmem : x ^ (m + r - i) * p ^ (m - i) ∈ + pRightMulRange (k := k) p := by + rw [hpow] + simpa [mul_assoc] using + (pRightMulRange_mem_of_mul_p (k := k) p + (x ^ (m + r - i) * p ^ (m - i - 1))) + have hzero : Submodule.mkQ (pRightMulRange (k := k) p) + (x ^ (m + r - i) * p ^ (m - i)) = 0 := + (Submodule.Quotient.mk_eq_zero (pRightMulRange (k := k) p)).2 hmem + simp only [if_pos (by omega : i ≤ m + r), map_nsmul, hzero, smul_zero] + · simp + +lemma commutatorDerivation_mul_left (p b y : A) + (hpb : p * b = b * p) : + commutatorDerivation p (b * y) = b * commutatorDerivation p y := by + change p * (b * y) - (b * y) * p = b * (p * y - y * p) + rw [show p * (b * y) - (b * y) * p = (p * b) * y - b * (y * p) by + noncomm_ring, hpb] + noncomm_ring + +theorem commutator_iterate_mul_left (p b y : A) + (hpb : p * b = b * p) (j : ℕ) : + ((commutatorDerivation p)^[j]) (b * y) = + b * ((commutatorDerivation p)^[j]) y := by + induction j with + | zero => simp + | succ j ih => + rw [Function.iterate_succ_apply', ih, + commutatorDerivation_mul_left p b _ hpb] + congr 1 + rw [Function.iterate_succ_apply'] + +theorem commutator_iterate_add (p : A) (j : ℕ) (a b : A) : + ((commutatorDerivation p)^[j]) (a + b) = + ((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b := by + induction j with + | zero => simp + | succ j ih => + calc + ((commutatorDerivation p)^[j + 1]) (a + b) = + (commutatorDerivation p) + (((commutatorDerivation p)^[j]) (a + b)) := by + rw [Function.iterate_succ_apply'] + _ = (commutatorDerivation p) + (((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b) := by rw [ih] + _ = (commutatorDerivation p) (((commutatorDerivation p)^[j]) a) + + (commutatorDerivation p) (((commutatorDerivation p)^[j]) b) := by + change p * (((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b) - + ((((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b) * p) = _ + change p * (((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b) - + ((((commutatorDerivation p)^[j]) a + + ((commutatorDerivation p)^[j]) b) * p) = + (p * ((commutatorDerivation p)^[j]) a - + ((commutatorDerivation p)^[j]) a * p) + + (p * ((commutatorDerivation p)^[j]) b - + ((commutatorDerivation p)^[j]) b * p) + noncomm_ring + _ = ((commutatorDerivation p)^[j + 1]) a + + ((commutatorDerivation p)^[j + 1]) b := by + rw [Function.iterate_succ_apply', Function.iterate_succ_apply'] + +theorem commutator_iterate_sum (p : A) (j : ℕ) + (s : Finset ℕ) (f : ℕ → A) : + ((commutatorDerivation p)^[j]) (∑ i ∈ s, f i) = + ∑ i ∈ s, ((commutatorDerivation p)^[j]) (f i) := by + induction s using Finset.induction_on with + | empty => + have hz : ∀ n : ℕ, ((commutatorDerivation p)^[n]) 0 = 0 := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply'] + change p * (((commutatorDerivation p)^[n]) 0) - + (((commutatorDerivation p)^[n]) 0) * p = 0 + rw [ih] + simp + rw [Finset.sum_empty, Finset.sum_empty] + exact hz j + | @insert a s ha ih => + rw [Finset.sum_insert ha, commutator_iterate_add, ih, + Finset.sum_insert ha] + +theorem commutator_iterate_eval_monomial_of_le + (p b : B) (n j : ℕ) (hpb : ∀ c : B, + O.embed p * O.embed c = O.embed c * O.embed p) + (hDp : D p = -1) (hjn : j ≤ n) : + (((commutatorDerivation (O.embed p))^[j]) + (O.embed b * O.x ^ n)) = + O.embed b * (n.descFactorial j • O.x ^ (n - j)) := by + have hpx : O.embed p * O.x - O.x * O.embed p = 1 := by + rw [O.relation p, hDp] + simp + calc + ((commutatorDerivation (O.embed p))^[j]) + (O.embed b * O.x ^ n) = + O.embed b * + ((commutatorDerivation (O.embed p))^[j]) (O.x ^ n) := by + exact commutator_iterate_mul_left (O.embed p) (O.embed b) + (O.x ^ n) (hpb b) j + _ = O.embed b * (n.descFactorial j • O.x ^ (n - j)) := by + rw [commutator_iterate_pow_of_le (O.embed p) O.x hpx j n hjn] + +theorem commutator_iterate_eval_monomial + (p b : B) (n j : ℕ) (hpb : ∀ c : B, + O.embed p * O.embed c = O.embed c * O.embed p) + (hDp : D p = -1) : + (((commutatorDerivation (O.embed p))^[j]) + (O.embed b * O.x ^ n)) = + if j ≤ n then + O.embed b * (n.descFactorial j • O.x ^ (n - j)) + else 0 := by + have hpx : O.embed p * O.x - O.x * O.embed p = 1 := by + rw [O.relation p, hDp] + simp + rw [commutator_iterate_mul_left (O.embed p) (O.embed b) + (O.x ^ n) (hpb b) j] + rw [commutator_iterate_pow (O.embed p) O.x hpx j n] + by_cases hjn : j ≤ n <;> simp [hjn] + +/-- Evaluation of a normal polynomial in an ambient Ore ring. -/ +def eval (p : Polynomial B) : A := + p.sum (fun i b => O.embed b * O.x ^ i) + +theorem commutator_iterate_eval (p : A) (q : Polynomial B) (j : ℕ) : + ((commutatorDerivation p)^[j]) (eval D O q) = + ∑ i ∈ q.support, + ((commutatorDerivation p)^[j]) + (O.embed (q.coeff i) * O.x ^ i) := by + unfold eval + rw [Polynomial.sum_def] + exact commutator_iterate_sum p j q.support + (fun i => O.embed (q.coeff i) * O.x ^ i) + +lemma eval_zero : eval D O 0 = 0 := by + simp [eval, Polynomial.sum_def] + +lemma eval_add (p q : Polynomial B) : + eval D O (p + q) = eval D O p + eval D O q := by + unfold eval + apply Polynomial.sum_add_index + · intro i + simp + · intro i a b + rw [map_add, add_mul] + +/-- The additive evaluation homomorphism. -/ +def evalAddHom : Polynomial B →+ A where + toFun := eval D O + map_zero' := eval_zero D O + map_add' := eval_add D O + +lemma eval_monomial (b : B) (j : ℕ) : + eval D O (Polynomial.monomial j b) = O.embed b * O.x ^ j := by + by_cases hb : b = 0 + · subst b + simp [eval, Polynomial.sum_def] + · unfold eval + rw [Polynomial.sum_def, Polynomial.support_monomial j hb] + simp [Polynomial.coeff_monomial, hb] + +/-- The coefficient-left normal form of an iterated commutator. -/ +def commutatorNormal (q : Polynomial B) (j : ℕ) : Polynomial B := + ∑ i ∈ q.support, + if j ≤ i then + Polynomial.monomial (i - j) (i.descFactorial j • q.coeff i) + else 0 + +lemma commutatorNormal_degree_le (q : Polynomial B) (j : ℕ) : + (commutatorNormal q j).degree ≤ (q.natDegree - j : WithBot ℕ) := by + rw [Polynomial.degree_le_iff_coeff_zero] + intro n hn + have hn' : q.natDegree - j < n := by exact_mod_cast hn + unfold commutatorNormal + change (Polynomial.lcoeff B n) + (∑ i ∈ q.support, + if j ≤ i then + Polynomial.monomial (i - j) (i.descFactorial j • q.coeff i) + else 0) = 0 + rw [map_sum] + apply Finset.sum_eq_zero + intro i hi + have hi_le : i ≤ q.natDegree := Polynomial.le_natDegree_of_mem_supp i hi + by_cases hji : j ≤ i + · simp only [if_pos hji] + change (Polynomial.monomial (i - j) + (i.descFactorial j • q.coeff i)).coeff n = 0 + rw [Polynomial.coeff_monomial] + simp [show i - j ≠ n by omega] + · simp [hji] + +lemma commutatorNormal_coeff_top [Nontrivial B] (q : Polynomial B) (j : ℕ) + (hq : q.Monic) (hjn : j ≤ q.natDegree) : + (commutatorNormal q j).coeff (q.natDegree - j) = + q.natDegree.descFactorial j • (1 : B) := by + unfold commutatorNormal + change (Polynomial.lcoeff B (q.natDegree - j)) + (∑ i ∈ q.support, + if j ≤ i then + Polynomial.monomial (i - j) (i.descFactorial j • q.coeff i) + else 0) = _ + rw [map_sum] + have hq0 : q ≠ 0 := hq.ne_zero + rw [Finset.sum_eq_single q.natDegree (by + intro i hi hne + have hi_le : i ≤ q.natDegree := + Polynomial.le_natDegree_of_mem_supp i hi + have hi_lt : i < q.natDegree := lt_of_le_of_ne hi_le hne + by_cases hji : j ≤ i + · have hneq : i - j ≠ q.natDegree - j := by omega + simp [hji, hneq, Polynomial.coeff_monomial] + · simp [hji]) (by + intro hnot + exact (hnot (Polynomial.natDegree_mem_support_of_nonzero hq0)).elim)] + simp [hjn, Polynomial.coeff_monomial, hq.leadingCoeff] + +theorem commutator_iterate_eval_eq_eval_normal + (p : B) (q : Polynomial B) (j : ℕ) + (hpb : ∀ c : B, + O.embed p * O.embed c = O.embed c * O.embed p) + (hDp : D p = -1) : + ((commutatorDerivation (O.embed p))^[j]) (eval D O q) = + eval D O (commutatorNormal q j) := by + rw [commutator_iterate_eval] + change (∑ i ∈ q.support, + ((commutatorDerivation (O.embed p))^[j]) + (O.embed (q.coeff i) * O.x ^ i)) = + (evalAddHom D O) (∑ i ∈ q.support, + if j ≤ i then + Polynomial.monomial (i - j) (i.descFactorial j • q.coeff i) + else 0) + rw [map_sum] + apply Finset.sum_congr rfl + intro i hi + by_cases hji : j ≤ i + · simp only [if_pos hji] + rw [commutator_iterate_eval_monomial D O p (q.coeff i) i j hpb hDp] + rw [if_pos hji] + change O.embed (q.coeff i) * + (i.descFactorial j • O.x ^ (i - j)) = + eval D O (Polynomial.monomial (i - j) + (i.descFactorial j • q.coeff i)) + rw [eval_monomial] + simp [map_nsmul, smul_mul_assoc] + simp [Nat.cast_comm, mul_assoc] + · rw [commutator_iterate_eval_monomial D O p (q.coeff i) i j hpb hDp] + simp [hji] + +lemma eval_push_eq_expansion (b : B) (n : ℕ) : + eval D O (OreDivision.push D b n) = expansion D O b n := by + change (evalAddHom D O) (OreDivision.push D b n) = expansion D O b n + unfold OreDivision.push + rw [map_sum] + change (∑ k ∈ Finset.range (n + 1), + eval D O (Polynomial.monomial (n - k) + (Nat.choose n k • (D^[k]) b))) = expansion D O b n + simp_rw [eval_monomial] + simp only [map_nsmul, smul_mul_assoc] + unfold expansion + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ + (fun i j => n.choose i • term D O b i j) n] + apply Finset.sum_congr rfl + intro k hk + rfl + +theorem eval_push (b : B) (n : ℕ) : + eval D O (OreDivision.push D b n) = O.x ^ n * O.embed b := by + rw [eval_push_eq_expansion, (pow_mul D O b n).symm] + +lemma eval_rightTerm (i : ℕ) (a b : B) (j : ℕ) : + eval D O (rightTerm D i a b j) = + (O.embed a * O.x ^ i) * (O.embed b * O.x ^ j) := by + change (evalAddHom D O) (rightTerm D i a b j) = _ + unfold rightTerm + rw [map_sum] + change (∑ k ∈ Finset.range (i + 1), + eval D O (Polynomial.monomial (i - k + j) + (a * (Nat.choose i k • (D^[k]) b)))) = _ + simp_rw [eval_monomial] + simp only [map_nsmul, map_mul] + calc + ∑ k ∈ Finset.range (i + 1), + O.embed a * (Nat.choose i k • O.embed ((D^[k]) b)) * + O.x ^ (i - k + j) = + O.embed a * + (∑ k ∈ Finset.range (i + 1), + Nat.choose i k • + (O.embed ((D^[k]) b) * O.x ^ (i - k)) * O.x ^ j) := by + simp_rw [mul_assoc, smul_mul_assoc] + rw [← Finset.mul_sum] + apply congrArg (fun z => O.embed a * z) + apply Finset.sum_congr rfl + intro k hk + rw [pow_add] + simp only [mul_assoc] + _ = O.embed a * + ((O.x ^ i * O.embed b) * O.x ^ j) := by + rw [← Finset.sum_mul] + congr 1 + apply congrArg (fun z => z * O.x ^ j) + change (∑ k ∈ Finset.range (i + 1), + i.choose k • term D O b k (i - k)) = O.x ^ i * O.embed b + rw [← Finset.Nat.sum_antidiagonal_eq_sum_range_succ + (fun u v => i.choose u • term D O b u v) i] + change expansion D O b i = O.x ^ i * O.embed b + exact (pow_mul D O b i).symm + _ = (O.embed a * O.x ^ i) * (O.embed b * O.x ^ j) := by + noncomm_ring + +lemma eval_rightMulMonomial (p : Polynomial B) (b : B) (j : ℕ) : + eval D O (rightMulMonomial D p b j) = + eval D O p * (O.embed b * O.x ^ j) := by + change (evalAddHom D O) (rightMulMonomial D p b j) = _ + unfold rightMulMonomial + change (evalAddHom D O) (∑ i ∈ p.support, + rightTerm D i (p.coeff i) b j) = _ + rw [map_sum] + change (∑ i ∈ p.support, + eval D O (rightTerm D i (p.coeff i) b j)) = _ + simp_rw [eval_rightTerm] + unfold eval + rw [Polynomial.sum_def, Finset.sum_mul] + +lemma eval_rightMul (d q : Polynomial B) : + eval D O (rightMul D d q) = eval D O d * eval D O q := by + change (evalAddHom D O) (rightMul D d q) = _ + unfold rightMul + change (evalAddHom D O) (∑ j ∈ q.support, + rightMulMonomial D d (q.coeff j) j) = _ + rw [map_sum] + change (∑ j ∈ q.support, + eval D O (rightMulMonomial D d (q.coeff j) j)) = _ + simp_rw [eval_rightMulMonomial] + unfold eval + simp only [Polynomial.sum_def] + rw [Finset.mul_sum] + +theorem eval_right_division_sound [Nontrivial B] (d p : Polynomial B) + (hd : d.Monic) : + ∃ q r : Polynomial B, + eval D O p = eval D O d * eval D O q + eval D O r ∧ + (r = 0 ∨ r.natDegree < d.natDegree) := by + obtain ⟨q, r, hdecomp, hrem⟩ := right_division_exists D d p hd + refine ⟨q, r, ?_, hrem⟩ + rw [hdecomp, eval_add D O, eval_rightMul D O] + +end OreAmbient + +end OreDivision + +end +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightHilbertBasis.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightHilbertBasis.lean new file mode 100644 index 0000000000..ff692daead --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightHilbertBasis.lean @@ -0,0 +1,565 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightQuotient +import Mathlib.RingTheory.Noetherian.Filter + +/-! +# The derivation-Ore right Hilbert-basis theorem + +This file is a right-sided version of the leading-coefficient proof for a +differential Ore extension. Coefficients are allowed to be noncommutative: +right ideals of the coefficient ring are represented as submodules for the +opposite scalar ring. +-/ + +namespace AlgebraicAnalysis.OreDerivationRightHilbertBasis + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open AlgebraicAnalysis.OreRightQuotient + +noncomputable section + +universe u + +variable {B : Type u} [Ring B] + +/-- The right Hilbert-basis assertion for one derivation-Ore stage. -/ +def DerivationOreRightHilbertBasis : Prop := + ∀ {B : Type u} [Ring B], IsNoetherianRing Bᵐᵒᵖ → + ∀ D : OreDivisionDerivation B, + IsNoetherianRing (NormalOre D)ᵐᵒᵖ + +@[simp] theorem rightScalar_smul_def (b : Bᵐᵒᵖ) (c : B) : + b • c = c * b.unop := by + rw [MulOpposite.smul_eq_mul_unop] + +private theorem rightScalar_top_span : + Submodule.span Bᵐᵒᵖ ({1} : Set B) = ⊤ := by + apply top_unique + intro c hc + have h1 : (1 : B) ∈ Submodule.span Bᵐᵒᵖ ({1} : Set B) := + Submodule.subset_span (by simp) + have hc' := Submodule.smul_mem + (Submodule.span Bᵐᵒᵖ ({1} : Set B)) (MulOpposite.op c) h1 + simpa [rightScalar_smul_def] using hc' + +private theorem rightScalar_module_finite : Module.Finite Bᵐᵒᵖ B := by + refine ⟨?_⟩ + refine ⟨({1} : Finset B), ?_⟩ + change Submodule.span Bᵐᵒᵖ (({1} : Finset B) : Set B) = ⊤ + simpa only [Finset.coe_singleton] using + (rightScalar_top_span (B := B)) + +private theorem rightScalar_isNoetherian + [IsNoetherianRing Bᵐᵒᵖ] : IsNoetherian Bᵐᵒᵖ B := by + letI : Module.Finite Bᵐᵒᵖ B := rightScalar_module_finite + exact isNoetherian_of_isNoetherianRing_of_finite Bᵐᵒᵖ B + +/-- Additive equivalence between coefficient-left polynomials and normal forms. -/ +def normalPolyEquiv (D : OreDivisionDerivation B) : + Polynomial B ≃+ NormalOre D := + { normalFormAddEquiv D with } + +lemma rightMul_coeff_C_of_degree_le + (D : OreDivisionDerivation B) (p : Polynomial B) (b : B) (n : ℕ) + (hp : p.degree ≤ (n : WithBot ℕ)) : + (rightMul D p (Polynomial.C b)).coeff n = p.coeff n * b := by + by_cases hp0 : p = 0 + · subst p + simp [OreDivision.rightMul, OreDivision.rightMulMonomial, + OreDivision.rightTerm] + have hpnat : p.natDegree ≤ n := + Polynomial.natDegree_le_of_degree_le hp + by_cases heq : p.natDegree = n + · rw [show Polynomial.C b = Polynomial.monomial 0 b by simp, + rightMul_monomial] + have htop := rightMulMonomial_coeff_top D p hp0 b 0 + rw [Nat.add_zero] at htop + simpa [Polynomial.leadingCoeff, heq] using htop + · have hlt : p.natDegree < n := lt_of_le_of_ne hpnat heq + have hprod : (rightMul D p (Polynomial.C b)).degree < + (n : WithBot ℕ) := by + have hle := rightMul_degree_le D p (Polynomial.C b) + have hnatC : (Polynomial.C b).natDegree = 0 := by simp + rw [hnatC] at hle + have hle' : (rightMul D p (Polynomial.C b)).degree ≤ + (p.natDegree : WithBot ℕ) := by simpa using hle + exact lt_of_le_of_lt hle' (WithBot.coe_lt_coe.2 hlt) + have hzprod := Polynomial.coeff_eq_zero_of_degree_lt hprod + have hz : p.coeff n = 0 := by + apply Polynomial.coeff_eq_zero_of_degree_lt + rw [Polynomial.degree_eq_natDegree hp0] + exact WithBot.coe_lt_coe.2 hlt + simp [hzprod, hz] + +/-- The degree-at-most-`n` submodule of normal forms. -/ +def normalDegreeLE (D : OreDivisionDerivation B) (n : ℕ) : + Submodule Bᵐᵒᵖ (NormalOre D) := + { carrier := {z | ((normalPolyEquiv D).symm z).degree ≤ (n : WithBot ℕ)} + zero_mem' := by + change ((normalPolyEquiv D).symm (0 : NormalOre D)).degree ≤ _ + rw [(normalPolyEquiv D).symm.map_zero] + simp + add_mem' := by + intro x y hx hy + change ((normalPolyEquiv D).symm (x + y)).degree ≤ _ + rw [(normalPolyEquiv D).symm.map_add] + exact le_trans (Polynomial.degree_add_le _ _) (max_le hx hy) + smul_mem' := by + intro b z hz + obtain ⟨p, rfl⟩ := normalForm_surjective D z + change ((normalPolyEquiv D).symm (b • normalForm D p)).degree ≤ _ + change ((normalPolyEquiv D).symm ((normalPolyEquiv D) p)).degree ≤ _ at hz + rw [(normalPolyEquiv D).symm_apply_apply] at hz + have hpdeg : p.degree ≤ (n : WithBot ℕ) := hz + have hpnat : p.natDegree ≤ n := + Polynomial.natDegree_le_of_degree_le hpdeg + have hmul : b • normalForm D p = + normalForm D (rightMul D p (Polynomial.C b.unop)) := by + rw [normalOre_op_smul_def, ← normalForm_C, ← normalForm_mul] + rw [hmul] + change ((normalPolyEquiv D).symm + ((normalPolyEquiv D) (rightMul D p (Polynomial.C b.unop)))).degree ≤ _ + rw [(normalPolyEquiv D).symm_apply_apply] + exact (rightMul_degree_le D p (Polynomial.C b.unop)).trans + (by + simp only [Polynomial.natDegree_C, Nat.cast_zero, add_zero] + exact_mod_cast hpnat) } + +/-- The `n`th coefficient functional on the degree window. -/ +def normalCoeffNth (D : OreDivisionDerivation B) (n : ℕ) : + normalDegreeLE D n →ₗ[Bᵐᵒᵖ] B where + toFun z := ((normalPolyEquiv D).symm z).coeff n + map_add' x y := by + change ((normalPolyEquiv D).symm (x + y)).coeff n = _ + rw [(normalPolyEquiv D).symm.map_add, Polynomial.coeff_add] + map_smul' b z := by + let p := (normalPolyEquiv D).symm z.1 + have hp : p.degree ≤ (n : WithBot ℕ) := by + change ((normalPolyEquiv D).symm z.1).degree ≤ _ + exact z.2 + have hz : normalForm D p = z.1 := by + change (normalPolyEquiv D) p = z.1 + exact (normalPolyEquiv D).apply_symm_apply z.1 + change ((normalPolyEquiv D).symm (b • z.1)).coeff n = + b • ((normalPolyEquiv D).symm z.1).coeff n + rw [← hz] + rw [normalOre_op_smul_def, ← normalForm_C, ← normalForm_mul] + change ((normalPolyEquiv D).symm + ((normalPolyEquiv D) (rightMul D p (Polynomial.C b.unop)))).coeff n = + b • ((normalPolyEquiv D).symm ((normalPolyEquiv D) p)).coeff n + rw [(normalPolyEquiv D).symm_apply_apply, + (normalPolyEquiv D).symm_apply_apply] + rw [rightMul_coeff_C_of_degree_le D p b.unop n hp] + rfl + +/-- The degree window cut out by a right ideal. -/ +def rightIdealDegreeLE (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) (n : ℕ) : + Submodule Bᵐᵒᵖ (NormalOre D) := + normalDegreeLE D n ⊓ rightIdealAsCoeffSubmodule D I + +/-- The leading-coefficient submodule at a fixed degree. -/ +def leadingCoeffNth (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) (n : ℕ) : + Submodule Bᵐᵒᵖ B := + let J := rightIdealDegreeLE D I n + let incl : J →ₗ[Bᵐᵒᵖ] normalDegreeLE D n := + { toFun := fun z => ⟨z.1, z.2.1⟩ + map_add' := by intro x y; rfl + map_smul' := by intro b x; rfl } + let f : J →ₗ[Bᵐᵒᵖ] B := (normalCoeffNth D n).comp incl + Submodule.map f (⊤ : Submodule Bᵐᵒᵖ J) + +lemma mem_leadingCoeffNth (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) (n : ℕ) (c : B) : + c ∈ leadingCoeffNth D I n ↔ + ∃ p : Polynomial B, normalForm D p ∈ I ∧ + p.degree ≤ (n : WithBot ℕ) ∧ p.coeff n = c := by + constructor + · intro hc + change c ∈ Submodule.map _ (⊤ : Submodule Bᵐᵒᵖ (rightIdealDegreeLE D I n)) at hc + rw [Submodule.mem_map] at hc + rcases hc with ⟨z, hz, rfl⟩ + let p := (normalPolyEquiv D).symm z.1 + refine ⟨p, ?_, ?_, ?_⟩ + · change normalForm D p ∈ I + have hpz : normalForm D p = z.1 := by + change (normalPolyEquiv D) p = z.1 + exact (normalPolyEquiv D).apply_symm_apply z.1 + rw [hpz] + simpa [rightIdealAsCoeffSubmodule] using z.2.2 + · change p.degree ≤ (n : WithBot ℕ) + exact z.2.1 + · change ((normalPolyEquiv D).symm z.1).coeff n = _ + rfl + · rintro ⟨p, hpI, hpdeg, hpc⟩ + let z : rightIdealDegreeLE D I n := + ⟨normalForm D p, (by + change ((normalPolyEquiv D).symm ((normalPolyEquiv D) p)).degree ≤ _ + rw [(normalPolyEquiv D).symm_apply_apply] + exact hpdeg), hpI⟩ + refine ⟨z, Submodule.mem_top, ?_⟩ + dsimp [z, normalCoeffNth] + have hinv : (normalPolyEquiv D).symm (normalForm D p) = p := by + change (normalPolyEquiv D).symm ((normalPolyEquiv D) p) = p + exact (normalPolyEquiv D).symm_apply_apply p + rw [hinv] + exact hpc + +lemma rightMul_Xpow_coeff_of_degree_le + [Nontrivial B] + (D : OreDivisionDerivation B) (p : Polynomial B) (n j : ℕ) + (hp : p.degree ≤ (n : WithBot ℕ)) : + (rightMul D p (Polynomial.X ^ j)).coeff (n + j) = p.coeff n := by + by_cases hp0 : p = 0 + · subst p + simp [OreDivision.rightMul, OreDivision.rightMulMonomial, + OreDivision.rightTerm, Polynomial.sum_def] + have hpnat : p.natDegree ≤ n := + Polynomial.natDegree_le_of_degree_le hp + by_cases heq : p.natDegree = n + · rw [Polynomial.X_pow_eq_monomial, rightMul_monomial] + have htop := rightMulMonomial_coeff_top D p hp0 1 j + simpa [Polynomial.leadingCoeff, heq] using htop + · have hlt : p.natDegree < n := lt_of_le_of_ne hpnat heq + have hprod : (rightMul D p (Polynomial.X ^ j)).degree < + ((n + j : ℕ) : WithBot ℕ) := by + have hle := rightMul_degree_le D p (Polynomial.X ^ j) + have hnatX : (Polynomial.X ^ j : Polynomial B).natDegree = j := by + simp + rw [hnatX] at hle + have hlt' : p.natDegree + j < n + j := Nat.add_lt_add_right hlt j + exact lt_of_le_of_lt hle (WithBot.coe_lt_coe.2 hlt') + have hzprod := Polynomial.coeff_eq_zero_of_degree_lt hprod + have hz : p.coeff n = 0 := by + apply Polynomial.coeff_eq_zero_of_degree_lt + rw [Polynomial.degree_eq_natDegree hp0] + exact WithBot.coe_lt_coe.2 hlt + simp [hzprod, hz] + +lemma leadingCoeffNth_mono [Nontrivial B] (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) + {m n : ℕ} (hmn : m ≤ n) : + leadingCoeffNth D I m ≤ leadingCoeffNth D I n := by + intro c hc + rw [mem_leadingCoeffNth] at hc ⊢ + rcases hc with ⟨p, hpI, hpdeg, hpc⟩ + refine ⟨rightMul D p (Polynomial.X ^ (n - m)), ?_, ?_, ?_⟩ + · rw [normalForm_mul] + have hmem := I.smul_mem + (MulOpposite.op (normalForm D (Polynomial.X ^ (n - m)))) hpI + simpa [op_smul_eq_mul] using hmem + · have hpnat : p.natDegree ≤ m := + Polynomial.natDegree_le_of_degree_le hpdeg + have hdeg := rightMul_degree_le D p (Polynomial.X ^ (n - m)) + have hnat : (Polynomial.X ^ (n - m) : Polynomial B).natDegree = n - m := + Polynomial.natDegree_X_pow _ + rw [hnat] at hdeg + have hadd : p.natDegree + (n - m) ≤ n := by + exact (Nat.add_le_add_right hpnat (n - m)).trans_eq + (Nat.add_sub_of_le hmn) + exact hdeg.trans (by exact_mod_cast hadd) + · have hc' := rightMul_Xpow_coeff_of_degree_le D p m (n - m) hpdeg + rw [Nat.add_sub_of_le hmn] at hc' + exact hc'.trans hpc + +/-- The monotone chain of leading-coefficient submodules. -/ +def leadingCoeffChain [Nontrivial B] (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) : + ℕ →o Submodule Bᵐᵒᵖ B where + toFun n := leadingCoeffNth D I n + monotone' _m _n h := leadingCoeffNth_mono D I h + +theorem exists_leadingCoeff_stable + [Nontrivial B] + [IsNoetherianRing Bᵐᵒᵖ] + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) : + ∃ N : ℕ, ∀ n, N ≤ n → leadingCoeffNth D I n = leadingCoeffNth D I N := by + letI : IsNoetherian Bᵐᵒᵖ B := rightScalar_isNoetherian + let f := leadingCoeffChain D I + have hconst : Filter.EventuallyConst + (f : ℕ → Submodule Bᵐᵒᵖ B) Filter.atTop := + eventuallyConst_of_isNoetherian f + rcases Filter.eventuallyConst_atTop.mp hconst with ⟨N, hN⟩ + exact ⟨N, fun n hn => hN n hn⟩ + +lemma normalDegreeLE_le_window (D : OreDivisionDerivation B) (n : ℕ) : + normalDegreeLE D n ≤ rightCoefficientWindow D (n + 1) := by + intro z hz + let p := (normalPolyEquiv D).symm z + have hpdeg : p.degree ≤ (n : WithBot ℕ) := by + change ((normalPolyEquiv D).symm z).degree ≤ _ + exact hz + have hp : p = 0 ∨ p.natDegree < n + 1 := by + by_cases hp0 : p = 0 + · exact Or.inl hp0 + · right + have hpnat : p.natDegree ≤ n := + Polynomial.natDegree_le_of_degree_le hpdeg + omega + have hw := normalForm_mem_rightCoefficientWindow_of_degree_lt + D p (n + 1) hp + have hzval : normalForm D p = z := by + change (normalPolyEquiv D) p = z + exact (normalPolyEquiv D).apply_symm_apply z + rw [← hzval] + exact hw + +/-- The degree window embedded in the finite coefficient window. -/ +def normalDegreeLEToWindow (D : OreDivisionDerivation B) (n : ℕ) : + normalDegreeLE D n →ₗ[Bᵐᵒᵖ] rightCoefficientWindow D (n + 1) where + toFun z := ⟨z.1, normalDegreeLE_le_window D n z.2⟩ + map_add' x y := by rfl + map_smul' b x := by rfl + +/-- Inclusion of an ideal degree window into the full degree window. -/ +def normalDegreeIncl (D : OreDivisionDerivation B) (n : ℕ) + (J : Submodule Bᵐᵒᵖ (NormalOre D)) + (hJ : J ≤ normalDegreeLE D n) : + J →ₗ[Bᵐᵒᵖ] normalDegreeLE D n where + toFun z := ⟨z.1, hJ z.2⟩ + map_add' x y := by rfl + map_smul' b x := by rfl + +theorem rightIdealDegreeLE_fg + [IsNoetherianRing Bᵐᵒᵖ] + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) (n : ℕ) : + (rightIdealDegreeLE D I n).FG := by + letI : Module.Finite Bᵐᵒᵖ (rightCoefficientWindow D (n + 1)) := + Module.Finite.span_of_finite Bᵐᵒᵖ (Set.finite_range + (fun j : Fin (n + 1) => normalForm D (Polynomial.X ^ (j : ℕ)))) + letI : IsNoetherian Bᵐᵒᵖ (rightCoefficientWindow D (n + 1)) := + isNoetherian_of_isNoetherianRing_of_finite Bᵐᵒᵖ + (rightCoefficientWindow D (n + 1)) + letI : Module.Finite Bᵐᵒᵖ (normalDegreeLE D n) := + Module.Finite.of_injective + (normalDegreeLEToWindow D n) (by + intro x y h + apply Subtype.ext + exact congrArg + (fun z : rightCoefficientWindow D (n + 1) => (z : NormalOre D)) h) + letI : IsNoetherian Bᵐᵒᵖ (normalDegreeLE D n) := + isNoetherian_of_isNoetherianRing_of_finite Bᵐᵒᵖ + (normalDegreeLE D n) + let incl := normalDegreeIncl D n (rightIdealDegreeLE D I n) inf_le_left + letI : Module.Finite Bᵐᵒᵖ (rightIdealDegreeLE D I n) := + Module.Finite.of_injective incl (by + intro x y h + apply Subtype.ext + exact congrArg + (fun z : normalDegreeLE D n => (z : NormalOre D)) h) + have htop : (⊤ : Submodule Bᵐᵒᵖ (rightIdealDegreeLE D I n)).FG := + Module.finite_def.mp (inferInstance : + Module.Finite Bᵐᵒᵖ (rightIdealDegreeLE D I n)) + exact (Submodule.fg_top (rightIdealDegreeLE D I n)).mp htop + +theorem normalOre_rightIdeal_fg_of_op_noetherian + [Nontrivial B] [IsNoetherianRing Bᵐᵒᵖ] + (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) : I.FG := by + obtain ⟨N, hstable⟩ := exists_leadingCoeff_stable D I + obtain ⟨s, hs⟩ := rightIdealDegreeLE_fg D I N + let K : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D) := + Submodule.span (NormalOre D)ᵐᵒᵖ (s : Set (NormalOre D)) + have hKsub : K ≤ I := by + apply Submodule.span_le.2 + intro z hz + have hzJ : z ∈ rightIdealDegreeLE D I N := by + rw [← hs] + exact Submodule.subset_span hz + exact hzJ.2 + refine ⟨s, ?_⟩ + apply le_antisymm hKsub + intro z hz + obtain ⟨p, rfl⟩ := normalForm_surjective D z + have hBspan_le : + Submodule.span Bᵐᵒᵖ (s : Set (NormalOre D)) ≤ + rightIdealAsCoeffSubmodule D K := by + apply Submodule.span_le.2 + intro x hx + exact Submodule.subset_span hx + have hgen : ∀ n : ℕ, ∀ p : Polynomial B, + p.natDegree = n → normalForm D p ∈ I → normalForm D p ∈ K := by + intro n + induction n using Nat.strong_induction_on with + | h n ih => + intro p hpn hpI + by_cases hp0 : p = 0 + · subst p + simp [normalForm_zero] + by_cases hsmall : p.natDegree ≤ N + · have hpdeg : p.degree ≤ (N : WithBot ℕ) := by + rw [Polynomial.degree_eq_natDegree hp0] + exact WithBot.coe_le_coe.2 hsmall + have hnormalP : normalForm D p ∈ normalDegreeLE D N := by + have hinv : (normalPolyEquiv D).symm (normalForm D p) = p := by + change (normalPolyEquiv D).symm ((normalPolyEquiv D) p) = p + exact (normalPolyEquiv D).symm_apply_apply p + change ((normalPolyEquiv D).symm (normalForm D p)).degree ≤ + (N : WithBot ℕ) + rw [hinv] + exact hpdeg + have hpJ : normalForm D p ∈ rightIdealDegreeLE D I N := + ⟨hnormalP, hpI⟩ + have hpB : normalForm D p ∈ + Submodule.span Bᵐᵒᵖ (s : Set (NormalOre D)) := by + rw [hs] + exact hpJ + exact hBspan_le hpB + · have hlarge : N < p.natDegree := lt_of_not_ge hsmall + let c := p.leadingCoeff + have hcne : c ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hp0 + have hpc : p.coeff n = c := by + dsimp [c] + rw [Polynomial.leadingCoeff, hpn] + have hcN : c ∈ leadingCoeffNth D I N := by + rw [← hstable p.natDegree (le_of_lt hlarge)] + rw [mem_leadingCoeffNth] + refine ⟨p, hpI, ?_, ?_⟩ + · exact Polynomial.degree_le_natDegree + · dsimp [c] + rcases (mem_leadingCoeffNth D I N c).mp hcN with + ⟨q, hqI, hqdeg, hqcoeff⟩ + let u := rightMul D q (Polynomial.X ^ (n - N)) + have huI : normalForm D u ∈ I := by + rw [normalForm_mul] + have hmem := I.smul_mem + (MulOpposite.op (normalForm D (Polynomial.X ^ (n - N)))) hqI + simpa [u, op_smul_eq_mul] using hmem + have huK : normalForm D u ∈ K := by + have hnormalQ : normalForm D q ∈ normalDegreeLE D N := by + have hinv : (normalPolyEquiv D).symm (normalForm D q) = q := by + change (normalPolyEquiv D).symm ((normalPolyEquiv D) q) = q + exact (normalPolyEquiv D).symm_apply_apply q + change ((normalPolyEquiv D).symm (normalForm D q)).degree ≤ + (N : WithBot ℕ) + rw [hinv] + exact hqdeg + have hqJ : normalForm D q ∈ rightIdealDegreeLE D I N := + ⟨hnormalQ, hqI⟩ + have hqB : normalForm D q ∈ + Submodule.span Bᵐᵒᵖ (s : Set (NormalOre D)) := by + rw [hs] + exact hqJ + have hmulK := K.smul_mem + (MulOpposite.op (normalForm D (Polynomial.X ^ (n - N)))) + (hBspan_le hqB) + simpa [u, normalForm_mul, op_smul_eq_mul] using hmulK + have hucoeff : u.coeff n = c := by + dsimp [u] + have hqcoeff' := + rightMul_Xpow_coeff_of_degree_le D q N (n - N) hqdeg + have hNn : N ≤ n := hpn ▸ le_of_lt hlarge + rw [Nat.add_sub_of_le hNn] at hqcoeff' + rw [hqcoeff'] + exact hqcoeff + have hu0 : u ≠ 0 := by + intro hu + have hthis : u.coeff n = (0 : Polynomial B).coeff n := by + simpa using congrArg (fun r : Polynomial B => r.coeff n) hu + rw [hucoeff] at hthis + exact hcne (by simpa using hthis) + have hule : u.degree ≤ (n : WithBot ℕ) := by + dsimp [u] + have hdeg := rightMul_degree_le D q (Polynomial.X ^ (n - N)) + have hqnat : q.natDegree ≤ N := + Polynomial.natDegree_le_of_degree_le hqdeg + have hnatX : (Polynomial.X ^ (n - N) : Polynomial B).natDegree = + n - N := Polynomial.natDegree_X_pow _ + rw [hnatX] at hdeg + have hadd : q.natDegree + (n - N) ≤ n := by + exact (Nat.add_le_add_right hqnat (n - N)).trans_eq + (Nat.add_sub_of_le (hpn ▸ le_of_lt hlarge)) + exact hdeg.trans (by exact_mod_cast hadd) + have hun : u.natDegree = n := by + apply le_antisymm + · exact Polynomial.natDegree_le_of_degree_le hule + · apply Polynomial.le_natDegree_of_mem_supp + rw [Polynomial.mem_support_iff] + exact hucoeff.trans_ne hcne + have hudeg : u.degree = (n : WithBot ℕ) := by + rw [Polynomial.degree_eq_natDegree hu0, hun] + have hpdeg : p.degree = (n : WithBot ℕ) := by + rw [Polynomial.degree_eq_natDegree hp0, hpn] + have hplead : p.leadingCoeff = u.leadingCoeff := by + rw [Polynomial.leadingCoeff, hpn, + Polynomial.leadingCoeff, hun, hpc, hucoeff] + let r := p - u + have hrI : normalForm D r ∈ I := by + dsimp [r] + rw [show normalForm D (p - u) = + normalForm D p - normalForm D u from + map_sub (normalFormAddHom D) p u] + exact I.sub_mem hpI huI + have hrdeg : r.degree < (n : WithBot ℕ) := by + dsimp [r] + have hsub := Polynomial.degree_sub_lt (hpdeg.trans hudeg.symm) hp0 hplead + simpa [hpdeg] using hsub + by_cases hr0 : r = 0 + · have hpr : p = u := sub_eq_zero.mp hr0 + rw [hpr] + exact huK + · have hrnat : r.natDegree < n := by + have hrdeg' : (r.natDegree : WithBot ℕ) < + (n : WithBot ℕ) := by + rw [Polynomial.degree_eq_natDegree hr0] at hrdeg + exact hrdeg + exact WithBot.coe_lt_coe.mp hrdeg' + have hrK := ih r.natDegree hrnat r rfl hrI + have huK' := huK + change normalForm D p ∈ K + rw [show p = u + r by dsimp [r]; abel, normalForm_add] + exact K.add_mem huK' hrK + exact hgen p.natDegree p rfl hz + +theorem normalOre_op_isNoetherian_of_nontrivial + [Nontrivial B] [IsNoetherianRing Bᵐᵒᵖ] + (D : OreDivisionDerivation B) : + IsNoetherianRing (NormalOre D)ᵐᵒᵖ := by + refine ⟨?_⟩ + intro J + let e : NormalOre D ≃ₗ[(NormalOre D)ᵐᵒᵖ] (NormalOre D)ᵐᵒᵖ := + MulOpposite.opLinearEquiv (NormalOre D)ᵐᵒᵖ + let I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D) := + J.comap e.toLinearMap + have hI : I.FG := normalOre_rightIdeal_fg_of_op_noetherian D I + have hmap : I.map e.toLinearMap = J := by + exact Submodule.map_comap_eq_of_surjective e.surjective J + rw [← hmap] + exact hI.map e.toLinearMap + +theorem normalOre_op_isNoetherian_of_subsingleton + [Subsingleton B] (D : OreDivisionDerivation B) : + IsNoetherianRing (NormalOre D)ᵐᵒᵖ := by + letI : Subsingleton (NormalOre D) := + ⟨fun x y => by + obtain ⟨p, rfl⟩ := normalForm_surjective D x + obtain ⟨q, rfl⟩ := normalForm_surjective D y + exact congrArg (normalForm D) (Subsingleton.elim p q)⟩ + rw [isNoetherianRing_iff] + exact isNoetherian_of_subsingleton + (NormalOre D)ᵐᵒᵖ (NormalOre D)ᵐᵒᵖ + +theorem derivationOre_rightHilbertBasis : + DerivationOreRightHilbertBasis.{u} := by + intro B _ hB D + letI : IsNoetherianRing Bᵐᵒᵖ := hB + by_cases hnt : Nontrivial B + · letI : Nontrivial B := hnt + exact normalOre_op_isNoetherian_of_nontrivial D + · haveI : Subsingleton B := not_nontrivial_iff_subsingleton.mp hnt + exact normalOre_op_isNoetherian_of_subsingleton D + +end + +end AlgebraicAnalysis.OreDerivationRightHilbertBasis diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightIntersection.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightIntersection.lean new file mode 100644 index 0000000000..45652fc5a3 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightIntersection.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Finite intersections in a right Ore domain + +Right ideals are represented as left modules over the opposite ring. The +right Ore condition is kept as an explicit common-right-multiple hypothesis; +this module does not depend on a particular localization construction. +-/ + +namespace AlgebraicAnalysis.OreRightIntersection + +variable {R : Type*} [Ring R] [IsDomain R] + +/-- Every pair of nonzero elements has a nonzero common right multiple. -/ +def RightOreCondition (R : Type*) [SemigroupWithZero R] : Prop := + ∀ ⦃a b : R⦄, a ≠ 0 → b ≠ 0 → + ∃ x y : R, a * x = b * y ∧ a * x ≠ 0 + +/-- A finite family of nonzero right ideals has a nonzero common element. + +The right ideals are left `Rᵐᵒᵖ`-submodules, so multiplying a member on the +right is expressed by scalar multiplication by `MulOpposite.op`. -/ +theorem exists_mem_finset_rightIdeals + {ι : Type*} [DecidableEq ι] + (s : Finset ι) (I : ι → Submodule Rᵐᵒᵖ R) + (hI : ∀ i ∈ s, ∃ x ∈ I i, x ≠ 0) + (hOre : RightOreCondition R) : + ∃ x : R, x ≠ 0 ∧ ∀ i ∈ s, x ∈ I i := by + classical + induction s using Finset.induction_on with + | empty => + exact ⟨1, one_ne_zero, by simp⟩ + | @insert i s hi ih => + obtain ⟨m, hm0, hm⟩ := ih (fun j hj => hI j (Finset.mem_insert_of_mem hj)) + obtain ⟨n, hnI, hn0⟩ := hI i (Finset.mem_insert_self i s) + obtain ⟨x, y, hxy, hmx0⟩ := hOre hm0 hn0 + refine ⟨m * x, hmx0, ?_⟩ + intro j hj + rcases Finset.mem_insert.mp hj with hji | hj + · subst j + rw [hxy] + exact (I i).smul_mem (MulOpposite.op y) hnI + · exact (I j).smul_mem (MulOpposite.op x) (hm j hj) + +/- The theorem is intentionally stated with an explicit nonzero witness; + this is the usual meaning of ``the intersection is nonzero''. -/ + +end AlgebraicAnalysis.OreRightIntersection diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightLocalization.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightLocalization.lean new file mode 100644 index 0000000000..539c7546fb --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightLocalization.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.OreLocalization.Ring +import Mathlib.Algebra.Ring.Opposite +import Mathlib.Algebra.Group.Units.Opposite + +/-! +# Right Ore localization + +The opposite-ring presentation of a right Ore localization and its +right-denominator clearing API. Extracted from Stafford38 commit +c8a513d553b24c7c08da82f496c44dbbaeb1f2fc. +-/ + +namespace AlgebraicAnalysis.OreRightLocalization + +/-- The copy of `S` in the opposite ring. -/ +def oppositeSubmonoid {R : Type u} [Monoid R] (S : Submonoid R) : + Submonoid Rᵐᵒᵖ where + carrier := {x | x.unop ∈ S} + one_mem' := S.one_mem + mul_mem' := by + intro a b ha hb + exact S.mul_mem hb ha + +/-- The right Ore localization of `R`, implemented as the opposite of +Mathlib's left Ore localization of `Rᵐᵒᵖ`. -/ +abbrev RightOreLocalization (R : Type u) [Ring R] (S : Submonoid R) + [OreLocalization.OreSet (oppositeSubmonoid S)] := + (OreLocalization (oppositeSubmonoid S) (Rᵐᵒᵖ))ᵐᵒᵖ + +/-- The numerator map into the right Ore localization. -/ +def rightNumeratorRingHom + {R : Type u} [Ring R] {S : Submonoid R} + [OreLocalization.OreSet (oppositeSubmonoid S)] : + R →+* RightOreLocalization R S where + toFun r := MulOpposite.op + (OreLocalization.numeratorRingHom (S := oppositeSubmonoid S) (MulOpposite.op r)) + map_one' := by + apply MulOpposite.unop_injective + exact RingHom.map_one _ + map_zero' := by + apply MulOpposite.unop_injective + exact RingHom.map_zero _ + map_add' a b := by + apply MulOpposite.unop_injective + exact RingHom.map_add _ _ _ + map_mul' a b := by + apply MulOpposite.unop_injective + exact RingHom.map_mul _ (MulOpposite.op b) (MulOpposite.op a) + +/-- Every element of a right Ore localization has a right denominator in `S` +which is a unit and clears the fraction. -/ +theorem rightOre_clear + {R : Type u} [Ring R] {S : Submonoid R} + [OreLocalization.OreSet (oppositeSubmonoid S)] + (q : RightOreLocalization R S) : + ∃ a s : R, s ∈ S ∧ IsUnit (rightNumeratorRingHom (S := S) s) ∧ + q * rightNumeratorRingHom (S := S) s = rightNumeratorRingHom (S := S) a := by + generalize hx : q.unop = x + induction x using OreLocalization.ind with + | _ a s => + refine ⟨a.unop, s.val.unop, s.property, ?_, ?_⟩ + · exact isUnit_op.mpr (OreLocalization.numerator_isUnit + (R := Rᵐᵒᵖ) (S := oppositeSubmonoid S) s) + · apply MulOpposite.unop_injective + rw [show q = MulOpposite.op (a /ₒ s) by + apply MulOpposite.unop_injective + exact hx] + exact OreLocalization.mul_cancel (R := Rᵐᵒᵖ) + (S := oppositeSubmonoid S) (r := a) (s := s) (t := 1) + + +end AlgebraicAnalysis.OreRightLocalization diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightPBW.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightPBW.lean new file mode 100644 index 0000000000..b28acb5a12 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightPBW.lean @@ -0,0 +1,384 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightHilbertBasis +import Mathlib.LinearAlgebra.Basis.Basic +import Mathlib.LinearAlgebra.Finsupp.LinearCombination + +/-! +# Right-coefficient PBW data for one derivation-Ore stage + +The checked Ore interface gives the opposite-ring right action and the +triangular coefficient identities. We prove directly that the candidate +monomials form a genuine right basis; the proof uses finite-support maximal +degree induction, so no freeness or flatness assumption is introduced. +-/ + +namespace AlgebraicAnalysis.OreRightPBW + +open Polynomial +open Module +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open AlgebraicAnalysis.OreRightQuotient +open AlgebraicAnalysis.OreDerivationRightHilbertBasis + +noncomputable section + +universe u + +variable {B : Type u} [Ring B] + +/-- The candidate right-coefficient PBW monomial of order `n`. -/ +def rightPBWMonomial (D : OreDivisionDerivation B) (n : ℕ) : NormalOre D := + normalForm D (Polynomial.X ^ n) + +/-- The finitely supported right-coefficient combination of PBW monomials. -/ +def rightPBWCombination (D : OreDivisionDerivation B) : + (ℕ →₀ Bᵐᵒᵖ) →ₗ[Bᵐᵒᵖ] NormalOre D := + Finsupp.linearCombination Bᵐᵒᵖ (rightPBWMonomial D) + +lemma rightPBWCombination_single (D : OreDivisionDerivation B) + (n : ℕ) (b : Bᵐᵒᵖ) : + rightPBWCombination D (Finsupp.single n b) = + b • rightPBWMonomial D n := by + simp [rightPBWCombination] + +lemma rightPBWCombination_term_as_normalForm + (D : OreDivisionDerivation B) (n : ℕ) (b : Bᵐᵒᵖ) : + b • rightPBWMonomial D n = + normalForm D (OreDivision.rightMul D (Polynomial.X ^ n) + (Polynomial.C b.unop)) := by + rw [rightPBWMonomial, normalOre_op_smul_def, ← normalForm_C, + ← normalForm_mul] + +@[nolint unusedArguments] +lemma rightPBWCombination_finsupp_as_normalForm + [Nontrivial B] (D : OreDivisionDerivation B) (c : ℕ →₀ Bᵐᵒᵖ) : + rightPBWCombination D c = + normalForm D + (c.sum fun n b => OreDivision.rightMul D (Polynomial.X ^ n) + (Polynomial.C b.unop)) := by + rw [rightPBWCombination, Finsupp.linearCombination_apply] + rw [Finsupp.sum] + rw [Finsupp.sum] + change _ = normalFormAddHom D + (∑ a ∈ c.support, + OreDivision.rightMul D (Polynomial.X ^ a) + (Polynomial.C (c a).unop)) + rw [map_sum] + apply Finset.sum_congr rfl + intro n b + exact rightPBWCombination_term_as_normalForm D n (c n) + +lemma rightPBWCombination_eq_zero + [Nontrivial B] (D : OreDivisionDerivation B) (c : ℕ →₀ Bᵐᵒᵖ) + (hc : rightPBWCombination D c = 0) : c = 0 := by + classical + by_contra hcz + have hne : c.support.Nonempty := Finsupp.support_nonempty_iff.mpr hcz + let m : ℕ := c.support.max' hne + have hm : m ∈ c.support := c.support.max'_mem hne + have hle : ∀ a ∈ c.support, a ≤ m := by + intro a ha + exact Finset.le_max' c.support a ha + have hpoly : + c.sum (fun n b => OreDivision.rightMul D (Polynomial.X ^ n) + (Polynomial.C b.unop)) = 0 := by + have hnf : + normalForm D + (c.sum (fun n b => OreDivision.rightMul D (Polynomial.X ^ n) + (Polynomial.C b.unop))) = 0 := by + rw [← rightPBWCombination_finsupp_as_normalForm D c] + exact hc + apply normalForm_injective D + simpa using hnf + have hcoeff := congrArg (fun p : Polynomial B => p.coeff m) hpoly + simp only [Finsupp.sum] at hcoeff + dsimp at hcoeff + rw [← Polynomial.lcoeff_apply, map_sum] at hcoeff + have hterm : ∀ a ∈ c.support, + (OreDivision.rightMul D (Polynomial.X ^ a) + (Polynomial.C (c a).unop)).coeff m = + if a = m then (c a).unop else 0 := by + intro a ha + have ha_le := hle a ha + have hdeg : (Polynomial.X ^ a : Polynomial B).degree ≤ + (m : WithBot ℕ) := by + rw [Polynomial.degree_X_pow] + exact_mod_cast ha_le + have htop := rightMul_coeff_C_of_degree_le D + (Polynomial.X ^ a) (c a).unop m hdeg + by_cases ham : a = m + · subst a + simpa using htop + · rw [htop] + have hcoeffX : (Polynomial.X ^ a : Polynomial B).coeff m = 0 := by + rw [Polynomial.coeff_X_pow] + split_ifs with h + · exact False.elim (ham h.symm) + · rfl + rw [hcoeffX, zero_mul] + simp [ham] + rw [Finset.sum_eq_single m (fun a ha hneam => by + exact hterm a ha |>.trans (by simp [hneam])) + (by intro hnot; exact False.elim (hnot hm))] at hcoeff + have hcm' : + (OreDivision.rightMul D (Polynomial.X ^ m) + (Polynomial.C (c m).unop)).coeff m = 0 := by + simpa [Polynomial.lcoeff_apply] using hcoeff + have hcm : c m = 0 := by + have htop := hterm m hm + rw [if_pos rfl] at htop + have hcm'' : (c m).unop = 0 := by simpa [htop] using hcm' + exact MulOpposite.opEquiv.symm.injective hcm'' + exact (Finsupp.mem_support_iff.mp hm) hcm + +theorem rightPBWCombination_injective + [Nontrivial B] (D : OreDivisionDerivation B) : + Function.Injective (rightPBWCombination D) := by + intro c d h + have hz : rightPBWCombination D (c - d) = 0 := by + rw [map_sub, h, sub_self] + have hcd := rightPBWCombination_eq_zero D (c - d) hz + exact sub_eq_zero.mp hcd + +lemma rightPBWMonomial_mem_span (D : OreDivisionDerivation B) + (b : B) (n : ℕ) : + normalForm D (Polynomial.monomial n b) ∈ + Submodule.span Bᵐᵒᵖ (Set.range (rightPBWMonomial D)) := by + rw [normalForm_monomial_reverse] + apply Submodule.sum_mem + intro ij hij + rw [← Nat.cast_smul_eq_nsmul Bᵐᵒᵖ] + apply Submodule.smul_mem + have hpow : rightPBWMonomial D ij.2 ∈ + Submodule.span Bᵐᵒᵖ (Set.range (rightPBWMonomial D)) := by + apply Submodule.subset_span + exact ⟨ij.2, rfl⟩ + have hscalar : (MulOpposite.op ((D^[ij.1]) b)) • + rightPBWMonomial D ij.2 ∈ + Submodule.span Bᵐᵒᵖ (Set.range (rightPBWMonomial D)) := + Submodule.smul_mem _ _ hpow + by_cases heven : Even ij.1 + · rw [heven.neg_one_pow] + simpa only [one_mul, rightPBWMonomial] using hscalar + · have hodd : Odd ij.1 := Nat.not_even_iff_odd.mp heven + rw [hodd.neg_one_pow] + simpa only [neg_one_mul, rightPBWMonomial] using + (Submodule.span Bᵐᵒᵖ (Set.range (rightPBWMonomial D))).neg_mem hscalar + +theorem rightPBW_span_eq_top (D : OreDivisionDerivation B) : + Submodule.span Bᵐᵒᵖ (Set.range (rightPBWMonomial D)) = ⊤ := by + apply top_unique + intro z hz + obtain ⟨p, rfl⟩ := normalForm_surjective D z + change normalFormAddHom D p ∈ _ + rw [← Polynomial.sum_monomial_eq p, Polynomial.sum_def, + map_sum (normalFormAddHom D)] + apply Submodule.sum_mem + intro n hn + exact rightPBWMonomial_mem_span D (p.coeff n) n + +theorem rightOrePBW_linearIndependent + [Nontrivial B] (D : OreDivisionDerivation B) : + LinearIndependent Bᵐᵒᵖ (rightPBWMonomial D) := + (linearIndependent_iff_injective_finsuppLinearCombination).2 + (rightPBWCombination_injective D) + +/-- The right PBW basis of a one-stage derivation-Ore extension. -/ +def rightOrePBWBasis [Nontrivial B] (D : OreDivisionDerivation B) : + Basis ℕ Bᵐᵒᵖ (NormalOre D) := + Basis.mk (rightOrePBW_linearIndependent D) + (rightPBW_span_eq_top D).ge + +@[simp] theorem rightOrePBWBasis_apply [Nontrivial B] + (D : OreDivisionDerivation B) (n : ℕ) : + rightOrePBWBasis D n = rightPBWMonomial D n := by + exact Basis.mk_apply _ _ _ + +theorem rightOrePBWBasis_repr_symm_single [Nontrivial B] + (D : OreDivisionDerivation B) (n : ℕ) (b : Bᵐᵒᵖ) : + (rightOrePBWBasis D).repr.symm (Finsupp.single n b) = + b • rightPBWMonomial D n := by + rw [(rightOrePBWBasis D).repr_symm_single, rightOrePBWBasis_apply] + +@[simp, nolint simpNF] theorem rightPBWMonomial_zero (D : OreDivisionDerivation B) : + rightPBWMonomial D 0 = 1 := by + simp [rightPBWMonomial, normalForm_one] + +@[simp, nolint simpNF] theorem rightPBWMonomial_op_smul + (D : OreDivisionDerivation B) (b : Bᵐᵒᵖ) (n : ℕ) : + b • rightPBWMonomial D n = + normalForm D (Polynomial.X ^ n) * normalCoefficient D b.unop := by + exact normalOre_op_smul_def D b (rightPBWMonomial D n) + +/-- The finite window generated by the candidate right PBW monomials. -/ +def rightPBWWindow (D : OreDivisionDerivation B) (n : ℕ) : + Submodule Bᵐᵒᵖ (NormalOre D) := + Submodule.span Bᵐᵒᵖ + (Set.range fun j : Fin n => rightPBWMonomial D (j : ℕ)) + +theorem normalForm_mem_rightPBWWindow_of_degree_lt + (D : OreDivisionDerivation B) (p : Polynomial B) (n : ℕ) + (hp : p = 0 ∨ p.natDegree < n) : + normalForm D p ∈ rightPBWWindow D n := by + simpa [rightPBWWindow, rightPBWMonomial, rightCoefficientWindow] using + (normalForm_mem_rightCoefficientWindow_of_degree_lt D p n hp) + +@[nolint unusedArguments] +theorem rightPBWWindow_finite + [Nontrivial B] (D : OreDivisionDerivation B) (n : ℕ) : + Module.Finite Bᵐᵒᵖ (rightPBWWindow D n) := by + exact Module.Finite.span_of_finite Bᵐᵒᵖ + (Set.finite_range (fun j : Fin n => rightPBWMonomial D (j : ℕ))) + +@[simp, nolint simpNF] theorem rightPBWMonomial_apply (D : OreDivisionDerivation B) (n : ℕ) : + rightPBWMonomial D n = normalForm D (Polynomial.X ^ n) := rfl + +/-- Right multiplication by a PBW monomial has the expected top coefficient. +This is the triangular input for an eventual basis proof. -/ +theorem rightMul_Xpow_top_coefficient + [Nontrivial B] (D : OreDivisionDerivation B) (p : Polynomial B) + (n j : ℕ) (hp : p.degree ≤ (n : WithBot ℕ)) : + (rightMul D p (Polynomial.X ^ j)).coeff (n + j) = p.coeff n := by + exact rightMul_Xpow_coeff_of_degree_le D p n j hp + +theorem rightMul_Xpow_degree_le + [Nontrivial B] + (D : OreDivisionDerivation B) (p : Polynomial B) (j : ℕ) : + (rightMul D p (Polynomial.X ^ j)).degree ≤ + (p.natDegree + j : WithBot ℕ) := by + have h := rightMul_degree_le D p (Polynomial.X ^ j) + have hX : (Polynomial.X ^ j : Polynomial B).natDegree = j := by + exact Polynomial.natDegree_X_pow _ + rw [hX] at h + exact h + +/-! ## Monic principal quotients -/ + +/-- A vector in the first `N` right-PBW slots has a coefficient-left normal +form of degree strictly less than `N`. This is the converse, at the level +needed for division, of `normalForm_mem_rightPBWWindow_of_degree_lt`. -/ +theorem exists_lowDegreePolynomial_eq_of_mem_rightPBWWindow + [Nontrivial B] (D : OreDivisionDerivation B) (N : ℕ) + {z : NormalOre D} (hz : z ∈ rightPBWWindow D N) : + ∃ r : Polynomial B, + (r = 0 ∨ r.natDegree < N) ∧ normalForm D r = z := by + change z ∈ Submodule.span Bᵐᵒᵖ + (Set.range fun j : Fin N ↦ normalForm D (Polynomial.X ^ (j : ℕ))) at hz + obtain ⟨c, hc⟩ := (Submodule.mem_span_range_iff_exists_fun Bᵐᵒᵖ).mp hz + let r : Polynomial B := ∑ j : Fin N, + rightMul D (Polynomial.X ^ (j : ℕ)) (Polynomial.C (c j).unop) + refine ⟨r, ?_, ?_⟩ + · by_cases hr : r = 0 + · exact Or.inl hr + · exact Or.inr ((Polynomial.natDegree_lt_iff_degree_lt hr).mpr (by + rw [Polynomial.degree_lt_iff_coeff_zero] + intro m hm + change (Polynomial.lcoeff B m) (∑ j : Fin N, + rightMul D (Polynomial.X ^ (j : ℕ)) + (Polynomial.C (c j).unop)) = 0 + rw [map_sum] + apply Finset.sum_eq_zero + intro j hj + apply Polynomial.coeff_eq_zero_of_degree_lt + have hdeg := rightMul_degree_le D + (Polynomial.X ^ (j : ℕ)) (Polynomial.C (c j).unop) + rw [Polynomial.natDegree_X_pow, Polynomial.natDegree_C] at hdeg + exact lt_of_le_of_lt hdeg (by exact_mod_cast j.isLt.trans_le hm))) + · change normalFormAddHom D (∑ j : Fin N, + rightMul D (Polynomial.X ^ (j : ℕ)) + (Polynomial.C (c j).unop)) = z + rw [map_sum, ← hc] + apply Finset.sum_congr rfl + intro j hj + change normalForm D (rightMul D (Polynomial.X ^ (j : ℕ)) + (Polynomial.C (c j).unop)) = _ + rw [normalForm_mul] + simp only [normalForm_C, normalOre_op_smul_def] + +/-- Monic right multiples and the finite right-PBW remainder window are exact +complements. Equivalently, monic right division is both exhaustive and +unique as a decomposition over the opposite coefficient ring. -/ +theorem monicPrincipalRightIdeal_isCompl_rightPBWWindow + [Nontrivial B] (D : OreDivisionDerivation B) + (H : Polynomial B) (hH : H.Monic) : + IsCompl (twoGeneratorCoeffSubmodule D H 0) + (rightPBWWindow D H.natDegree) := by + apply IsCompl.of_le + · intro z hz + have hzI := hz.1 + have hzW := hz.2 + change z ∈ twoGeneratorRightIdeal D H 0 at hzI + rw [twoGeneratorRightIdeal, Submodule.mem_span_pair] at hzI + obtain ⟨a, b, hab⟩ := hzI + have hzeroTerm : b • normalForm D (0 : Polynomial B) = 0 := by + rw [normalForm_zero, smul_zero] + rw [hzeroTerm, add_zero] at hab + change normalForm D H * a.unop = z at hab + obtain ⟨q, hq⟩ := normalForm_surjective D a.unop + obtain ⟨r, hrsmall, hrz⟩ := + exists_lowDegreePolynomial_eq_of_mem_rightPBWWindow D H.natDegree hzW + have hdecomp : r = rightMul D H q + 0 := by + apply normalForm_injective D + rw [normalForm_add, normalForm_zero, normalForm_mul, add_zero, hq] + exact hrz.trans hab.symm + have hzero := (right_division_unique D H r q 0 0 r hH + hdecomp (by simp [rightMul_zero]) (Or.inl rfl) hrsmall).2 + have hr0 : r = 0 := hzero.symm + rw [← hrz, hr0, normalForm_zero] + exact Submodule.zero_mem _ + · intro z hz + obtain ⟨p, rfl⟩ := normalForm_surjective D z + obtain ⟨q, r, hdecomp, hrsmall⟩ := right_division_exists D H p hH + rw [Submodule.mem_sup] + refine ⟨normalForm D (rightMul D H q), + normalForm_rightMul_H_mem_twoGeneratorCoeffSubmodule D H 0 q, + normalForm D r, + normalForm_mem_rightPBWWindow_of_degree_lt D r H.natDegree hrsmall, + ?_⟩ + rw [← normalForm_add, ← hdecomp] + +/-- The basis of the finite right-PBW remainder window. -/ +def rightPBWWindowBasis [Nontrivial B] + (D : OreDivisionDerivation B) (N : ℕ) : + Basis (Fin N) Bᵐᵒᵖ (rightPBWWindow D N) := + Basis.span ((rightOrePBW_linearIndependent D).comp + (fun j : Fin N ↦ (j : ℕ)) Fin.val_injective) + +/-- A monic principal right quotient of a derivation-Ore extension is free of +rank `H.natDegree` over the opposite coefficient ring, with basis represented +by `1, X, …, X^(H.natDegree-1)`. The `0` second generator is only a literal +encoding of the principal right ideal inside the existing quotient API. -/ +def monicPrincipalRightQuotientBasis [Nontrivial B] + (D : OreDivisionDerivation B) (H : Polynomial B) (hH : H.Monic) : + Basis (Fin H.natDegree) Bᵐᵒᵖ (TwoGeneratorQuotient D H 0) := + (rightPBWWindowBasis D H.natDegree).map + (Submodule.quotientEquivOfIsCompl + (twoGeneratorCoeffSubmodule D H 0) + (rightPBWWindow D H.natDegree) + (monicPrincipalRightIdeal_isCompl_rightPBWWindow D H hH)).symm + +@[simp] theorem monicPrincipalRightQuotientBasis_apply [Nontrivial B] + (D : OreDivisionDerivation B) (H : Polynomial B) (hH : H.Monic) + (j : Fin H.natDegree) : + monicPrincipalRightQuotientBasis D H hH j = + Submodule.Quotient.mk (normalForm D (Polynomial.X ^ (j : ℕ))) := by + rw [monicPrincipalRightQuotientBasis, Basis.map_apply, + Submodule.quotientEquivOfIsCompl_symm_apply] + congr 1 + change (((rightPBWWindowBasis D H.natDegree) j : + rightPBWWindow D H.natDegree) : NormalOre D) = + normalForm D (Polynomial.X ^ (j : ℕ)) + exact congrArg Subtype.val + (Basis.span_apply ((rightOrePBW_linearIndependent D).comp + (fun j : Fin H.natDegree ↦ (j : ℕ)) Fin.val_injective) j) + + +end +end AlgebraicAnalysis.OreRightPBW diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightQuotient.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightQuotient.lean new file mode 100644 index 0000000000..ce1bcd5d32 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/RightQuotient.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity + +/-! +# Finite right quotients over noncommutative Ore coefficients + +Monic right division leaves coefficient-left remainders. A signed reverse +normal-ordering identity rewrites them in a finite right-coefficient window. +The natural scalar ring is therefore `Bᵐᵒᵖ`, not `B`; this removes the +commutativity restriction from the older finite-quotient consumer. + +The final section instantiates the construction on the outer momentum layer +of the iterated Weyl tower and uses the literal generators `d` and `x^N d`. +-/ + +namespace AlgebraicAnalysis.OreRightQuotient + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + +variable {B : Type*} [Ring B] + +instance normalOreNontrivial [Nontrivial B] (D : OreDivisionDerivation B) : + Nontrivial (NormalOre D) := by + refine ⟨⟨0, 1, ?_⟩⟩ + intro h + have h' : normalForm D (0 : Polynomial B) = normalForm D 1 := by + rw [normalForm_zero, normalForm_one] + exact h + exact zero_ne_one (normalForm_injective D h') + +theorem normalCoefficient_injective (D : OreDivisionDerivation B) : + Function.Injective (normalCoefficient D) := by + intro a b h + apply Polynomial.C_injective + apply normalForm_injective D + simpa only [normalForm_C] using h + +instance normalOreOpSMul (D : OreDivisionDerivation B) : + SMul Bᵐᵒᵖ (NormalOre D) := + ⟨fun b a => a * normalCoefficient D b.unop⟩ + +instance normalOreOpModule (D : OreDivisionDerivation B) : + Module Bᵐᵒᵖ (NormalOre D) := + Module.ofMinimalAxioms + (fun b x y => by + change (x + y) * normalCoefficient D b.unop = + x * normalCoefficient D b.unop + y * normalCoefficient D b.unop + exact add_mul x y (normalCoefficient D b.unop)) + (fun b c x => by + change x * normalCoefficient D (b + c).unop = + x * normalCoefficient D b.unop + x * normalCoefficient D c.unop + rw [MulOpposite.unop_add, (normalCoefficient D).map_add, mul_add]) + (fun b c x => by + change x * normalCoefficient D (b * c).unop = + (x * normalCoefficient D c.unop) * normalCoefficient D b.unop + rw [MulOpposite.unop_mul, (normalCoefficient D).map_mul, mul_assoc]) + (fun x => by + change x * normalCoefficient D (1 : Bᵐᵒᵖ).unop = x + rw [MulOpposite.unop_one, (normalCoefficient D).map_one, mul_one]) + +@[simp] theorem normalOre_op_smul_def (D : OreDivisionDerivation B) + (b : Bᵐᵒᵖ) (a : NormalOre D) : + b • a = a * normalCoefficient D b.unop := rfl + +@[simp] theorem normalForm_X_pow_coe (D : OreDivisionDerivation B) (n : ℕ) : + (normalForm D (X ^ n) : AddMonoid.End (Polynomial B)) = + (leftOreShift D) ^ n := by + change OreAmbient.eval D (faithfulAmbient D) (X ^ n) = _ + rw [Polynomial.X_pow_eq_monomial, OreAmbient.eval_monomial] + simp [faithfulAmbient] + +theorem normalForm_monomial_reverse (D : OreDivisionDerivation B) + (b : B) (n : ℕ) : + normalForm D (monomial n b) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • + ((-1 : NormalOre D) ^ ij.1 * + ((MulOpposite.op ((D^[ij.1]) b)) • + normalForm D (X ^ ij.2))) := by + apply Subtype.ext + change OreAmbient.eval D (faithfulAmbient D) (monomial n b) = _ + rw [OreAmbient.eval_monomial] + rw [OreAmbient.reverse_mul D (faithfulAmbient D) b n] + unfold OreAmbient.reverseExpansion OreAmbient.reverseSignedTerm + OreAmbient.reverseTerm + change _ = (faithfulRange D).subtype + (∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • + ((-1 : NormalOre D) ^ ij.1 * + ((MulOpposite.op ((D^[ij.1]) b)) • + normalForm D (X ^ ij.2)))) + have hsum : + (faithfulRange D).subtype + (∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + n.choose ij.1 • + ((-1 : NormalOre D) ^ ij.1 * + ((MulOpposite.op ((D^[ij.1]) b)) • + normalForm D (X ^ ij.2)))) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + (faithfulRange D).subtype + (n.choose ij.1 • + ((-1 : NormalOre D) ^ ij.1 * + ((MulOpposite.op ((D^[ij.1]) b)) • + normalForm D (X ^ ij.2)))) := by + exact map_sum (faithfulRange D).subtype.toAddMonoidHom _ _ + rw [hsum] + apply Finset.sum_congr rfl + intro ij hij + change + n.choose ij.1 • + ((-1 : AddMonoid.End (Polynomial B)) ^ ij.1 * + ((leftOreShift D) ^ ij.2 * coefficientLeft ((D^[ij.1]) b))) = + n.choose ij.1 • + ((((-1 : NormalOre D) ^ ij.1 * + ((MulOpposite.op ((D^[ij.1]) b)) • + normalForm D (X ^ ij.2))) : NormalOre D) : + AddMonoid.End (Polynomial B)) + apply congrArg (fun z : AddMonoid.End (Polynomial B) => n.choose ij.1 • z) + simp only [normalOre_op_smul_def] + change + (-1 : AddMonoid.End (Polynomial B)) ^ ij.1 * + ((leftOreShift D) ^ ij.2 * coefficientLeft ((D^[ij.1]) b)) = + (-1 : AddMonoid.End (Polynomial B)) ^ ij.1 * + (((normalForm D (X ^ ij.2) : NormalOre D) : + AddMonoid.End (Polynomial B)) * coefficientLeft ((D^[ij.1]) b)) + rw [normalForm_X_pow_coe] + +/-- The finite right-coefficient window of order less than `n`. -/ +def rightCoefficientWindow (D : OreDivisionDerivation B) (n : ℕ) : + Submodule Bᵐᵒᵖ (NormalOre D) := + Submodule.span Bᵐᵒᵖ + (Set.range fun j : Fin n => normalForm D (X ^ (j : ℕ))) + +lemma normalForm_monomial_mem_rightCoefficientWindow + (D : OreDivisionDerivation B) (b : B) {j n : ℕ} (hj : j < n) : + normalForm D (monomial j b) ∈ rightCoefficientWindow D n := by + rw [normalForm_monomial_reverse] + apply Submodule.sum_mem + intro ij hij + rw [← Nat.cast_smul_eq_nsmul Bᵐᵒᵖ] + apply Submodule.smul_mem + have hijSum : ij.1 + ij.2 = j := + Finset.HasAntidiagonal.mem_antidiagonal.mp hij + have hijLt : ij.2 < n := by omega + have hpow : normalForm D (X ^ ij.2) ∈ rightCoefficientWindow D n := by + apply Submodule.subset_span + exact ⟨⟨ij.2, hijLt⟩, rfl⟩ + have hscalar : + (MulOpposite.op ((D^[ij.1]) b)) • normalForm D (X ^ ij.2) ∈ + rightCoefficientWindow D n := + Submodule.smul_mem _ _ hpow + by_cases heven : Even ij.1 + · rw [heven.neg_one_pow] + simpa only [one_mul] using hscalar + · have hodd : Odd ij.1 := Nat.not_even_iff_odd.mp heven + rw [hodd.neg_one_pow] + simpa only [neg_one_mul] using + (rightCoefficientWindow D n).neg_mem hscalar + +theorem normalForm_mem_rightCoefficientWindow_of_degree_lt + (D : OreDivisionDerivation B) (p : Polynomial B) (n : ℕ) + (hp : p = 0 ∨ p.natDegree < n) : + normalForm D p ∈ rightCoefficientWindow D n := by + rcases hp with rfl | hp + · simp + · change normalFormAddHom D p ∈ rightCoefficientWindow D n + rw [← Polynomial.sum_monomial_eq p, Polynomial.sum_def, + map_sum (normalFormAddHom D)] + apply Submodule.sum_mem + intro j hj + apply normalForm_monomial_mem_rightCoefficientWindow D + exact lt_of_le_of_lt (Polynomial.le_natDegree_of_mem_supp j hj) hp + +/-- A right ideal viewed as a coefficient-opposite submodule. -/ +def rightIdealAsCoeffSubmodule (D : OreDivisionDerivation B) + (I : Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D)) : + Submodule Bᵐᵒᵖ (NormalOre D) where + carrier := I + zero_mem' := I.zero_mem + add_mem' := I.add_mem + smul_mem' := by + intro b a ha + change a * normalCoefficient D b.unop ∈ I + rw [← op_smul_eq_mul] + exact I.smul_mem (MulOpposite.op (normalCoefficient D b.unop)) ha + +/-- The right ideal generated by two normal forms. -/ +def twoGeneratorRightIdeal (D : OreDivisionDerivation B) + (H J : Polynomial B) : + Submodule (NormalOre D)ᵐᵒᵖ (NormalOre D) := + Submodule.span (NormalOre D)ᵐᵒᵖ + ({normalForm D H, normalForm D J} : Set (NormalOre D)) + +/-- The coefficient-opposite submodule underlying a two-generator ideal. -/ +def twoGeneratorCoeffSubmodule (D : OreDivisionDerivation B) + (H J : Polynomial B) : Submodule Bᵐᵒᵖ (NormalOre D) := + rightIdealAsCoeffSubmodule D (twoGeneratorRightIdeal D H J) + +/-- The corresponding quotient as a coefficient-opposite module. -/ +abbrev TwoGeneratorQuotient (D : OreDivisionDerivation B) + (H J : Polynomial B) := + NormalOre D ⧸ twoGeneratorCoeffSubmodule D H J + +lemma normalForm_H_mem_twoGeneratorRightIdeal + (D : OreDivisionDerivation B) (H J : Polynomial B) : + normalForm D H ∈ twoGeneratorRightIdeal D H J := by + apply Submodule.subset_span + simp + +lemma normalForm_rightMul_H_mem_twoGeneratorCoeffSubmodule + (D : OreDivisionDerivation B) (H J q : Polynomial B) : + normalForm D (rightMul D H q) ∈ + twoGeneratorCoeffSubmodule D H J := by + change normalForm D (rightMul D H q) ∈ twoGeneratorRightIdeal D H J + rw [normalForm_mul, ← op_smul_eq_mul] + exact (twoGeneratorRightIdeal D H J).smul_mem + (MulOpposite.op (normalForm D q)) + (normalForm_H_mem_twoGeneratorRightIdeal D H J) + +theorem rightCoefficientWindow_quotient_surjective + [Nontrivial B] (D : OreDivisionDerivation B) + (H J : Polynomial B) (hH : H.Monic) : + Function.Surjective + ((twoGeneratorCoeffSubmodule D H J).mkQ.comp + (rightCoefficientWindow D H.natDegree).subtype) := by + intro y + obtain ⟨a, rfl⟩ := + (twoGeneratorCoeffSubmodule D H J).mkQ_surjective y + obtain ⟨p, rfl⟩ := normalForm_surjective D a + obtain ⟨q, r, hdecomp, hr⟩ := right_division_exists D H p hH + have hrWindow : normalForm D r ∈ + rightCoefficientWindow D H.natDegree := + normalForm_mem_rightCoefficientWindow_of_degree_lt D r H.natDegree hr + refine ⟨⟨normalForm D r, hrWindow⟩, ?_⟩ + change (twoGeneratorCoeffSubmodule D H J).mkQ (normalForm D r) = + (twoGeneratorCoeffSubmodule D H J).mkQ (normalForm D p) + apply (Submodule.Quotient.eq (twoGeneratorCoeffSubmodule D H J)).2 + have hmultiple : normalForm D (rightMul D H q) ∈ + twoGeneratorCoeffSubmodule D H J := + normalForm_rightMul_H_mem_twoGeneratorCoeffSubmodule D H J q + rw [hdecomp, normalForm_add] + simpa using (twoGeneratorCoeffSubmodule D H J).neg_mem hmultiple + +theorem twoGeneratorQuotient_finite + [Nontrivial B] (D : OreDivisionDerivation B) + (H J : Polynomial B) (hH : H.Monic) : + Module.Finite Bᵐᵒᵖ (TwoGeneratorQuotient D H J) := by + letI : Module.Finite Bᵐᵒᵖ (rightCoefficientWindow D H.natDegree) := + Module.Finite.span_of_finite Bᵐᵒᵖ (Set.finite_range + (fun j : Fin H.natDegree => normalForm D (X ^ (j : ℕ)))) + exact Module.Finite.of_surjective + ((twoGeneratorCoeffSubmodule D H J).mkQ.comp + (rightCoefficientWindow D H.natDegree).subtype) + (rightCoefficientWindow_quotient_surjective D H J hH) + + + +end +end AlgebraicAnalysis.OreRightQuotient diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Tower.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Tower.lean new file mode 100644 index 0000000000..8e72b730c5 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Ore/Tower.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.LeftPBW + +/-! +# Commuting derivations and the next Ore stage + +This file contains the coefficientwise lift needed in the iterated Ore tower. +If two coefficient derivations commute, the second one extends through the +first derivation-Ore extension by differentiating every coefficient in left +normal form. The formulas at the coefficient embedding and at the Ore +variable are part of the interface used by later tower stages. +-/ + +namespace AlgebraicAnalysis.OreTower + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + + +variable {B : Type*} [Ring B] + +/-! ## Commuting iterates -/ + +lemma iterate_apply_commute (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) (n : ℕ) (b : B) : + E ((D^[n]) b) = (D^[n]) (E b) := by + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply'] + calc + E (D ((D^[n]) b)) = D (E ((D^[n]) b)) := (hcomm _).symm + _ = D ((D^[n]) (E b)) := congrArg D ih + +lemma coefficientDerivation_commute (E F : OreDivisionDerivation B) + (hcomm : ∀ b : B, E (F b) = F (E b)) (p : Polynomial B) : + coefficientDerivation E (coefficientDerivation F p) = + coefficientDerivation F (coefficientDerivation E p) := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [map_add, map_add, map_add, map_add, hp, hq] + | monomial i b => + rw [coefficientDerivation_monomial, coefficientDerivation_monomial, + coefficientDerivation_monomial, coefficientDerivation_monomial, + hcomm] + +lemma coefficientDerivation_rightTerm (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) + (i : ℕ) (a b : B) (j : ℕ) : + coefficientDerivation E (rightTerm D i a b j) = + rightTerm D i (E a) b j + rightTerm D i a (E b) j := by + rw [rightTerm] + simp only [map_sum, coefficientDerivation_monomial] + simp only [rightTerm] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro k hk + rw [OreDivisionDerivation.leibniz] + rw [OreDivisionDerivation.map_nsmul] + rw [iterate_apply_commute D E hcomm] + rw [map_add] + exact add_comm _ _ + +lemma coefficientDerivation_rightMulMonomial (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) (p : Polynomial B) + (b : B) (j : ℕ) : + coefficientDerivation E (rightMulMonomial D p b j) = + rightMulMonomial D (coefficientDerivation E p) b j + + rightMulMonomial D p (E b) j := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [rightMulMonomial_add_left, map_add, hp, hq, map_add, + rightMulMonomial_add_left D p q (E b) j] + rw [rightMulMonomial_add_left D (coefficientDerivation E p) + (coefficientDerivation E q) b j] + abel + | monomial i a => + simp [rightMulMonomial, Polynomial.sum_monomial_index, rightTerm_zero] + exact coefficientDerivation_rightTerm D E hcomm i a b j + +lemma coefficientDerivation_rightMul (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) (p q : Polynomial B) : + coefficientDerivation E (rightMul D p q) = + rightMul D (coefficientDerivation E p) q + + rightMul D p (coefficientDerivation E q) := by + induction q using Polynomial.induction_on' with + | add q r hq hr => + rw [rightMul_add, map_add, hq, hr, map_add, rightMul_add, rightMul_add] + abel + | monomial j b => + simp only [rightMul_monomial, coefficientDerivation_monomial] + exact coefficientDerivation_rightMulMonomial D E hcomm p b j + +/-! ## The lifted derivation -/ + +/-- Differentiate the coefficients of a left-normal Ore polynomial. -/ +def liftDerivation (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) : + OreDivisionDerivation (NormalOre D) where + toFun z := + normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm z)) + map_zero' := by + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm 0)) = 0 + rw [(normalFormAddEquiv D).symm.map_zero, map_zero, normalForm_zero] + map_add' z w := by + have h := (normalFormAddEquiv D).symm.toAddHom.map_add z w + change (normalFormAddEquiv D).symm (z + w) = + (normalFormAddEquiv D).symm z + (normalFormAddEquiv D).symm w at h + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm (z + w))) = _ + rw [h, map_add, normalForm_add] + leibniz' := by + intro z w + rcases normalForm_surjective D z with ⟨p, rfl⟩ + rcases normalForm_surjective D w with ⟨q, rfl⟩ + rw [← normalForm_mul] + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm (normalForm D (rightMul D p q)))) = + normalForm D p * normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm (normalForm D q))) + + normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm (normalForm D p))) * normalForm D q + have hs (r : Polynomial B) : + (normalFormAddEquiv D).symm (normalForm D r) = r := by + change (normalFormAddEquiv D).symm ((normalFormAddEquiv D) r) = r + exact (normalFormAddEquiv D).symm_apply_apply r + rw [hs, hs, hs] + rw [coefficientDerivation_rightMul D E hcomm] + rw [normalForm_add, normalForm_mul, normalForm_mul] + rw [add_comm] + +@[simp] theorem liftDerivation_apply_normalForm + (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) (p : Polynomial B) : + liftDerivation D E hcomm (normalForm D p) = + normalForm D (coefficientDerivation E p) := by + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm (normalForm D p))) = + normalForm D (coefficientDerivation E p) + have hs : (normalFormAddEquiv D).symm (normalForm D p) = p := by + change (normalFormAddEquiv D).symm ((normalFormAddEquiv D) p) = p + exact (normalFormAddEquiv D).symm_apply_apply p + rw [hs] + +@[simp] theorem liftDerivation_apply_coefficient (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) (b : B) : + liftDerivation D E hcomm (normalCoefficient D b) = + normalCoefficient D (E b) := by + rw [← normalForm_C, ← normalForm_C] + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm ((normalFormAddEquiv D) (C b)))) = + normalForm D (C (E b)) + rw [(normalFormAddEquiv D).symm_apply_apply] + rw [← monomial_zero_left, coefficientDerivation_monomial] + rw [monomial_zero_left, normalForm_C] + +@[simp] theorem liftDerivation_apply_variable (D E : OreDivisionDerivation B) + (hcomm : ∀ b : B, D (E b) = E (D b)) : + liftDerivation D E hcomm (normalVariable D) = 0 := by + change normalForm D (coefficientDerivation E + ((normalFormAddEquiv D).symm ((normalFormAddEquiv D) Polynomial.X))) = 0 + rw [(normalFormAddEquiv D).symm_apply_apply] + rw [← Polynomial.monomial_one_one_eq_X, coefficientDerivation_monomial, + derivation_one E, monomial_zero_right, + normalForm_zero] + +theorem liftDerivation_commute + (D E F : OreDivisionDerivation B) + (hDE : ∀ b : B, D (E b) = E (D b)) + (hDF : ∀ b : B, D (F b) = F (D b)) + (hEF : ∀ b : B, E (F b) = F (E b)) (z : NormalOre D) : + liftDerivation D E hDE (liftDerivation D F hDF z) = + liftDerivation D F hDF (liftDerivation D E hDE z) := by + rcases normalForm_surjective D z with ⟨p, rfl⟩ + rw [liftDerivation_apply_normalForm, liftDerivation_apply_normalForm, + liftDerivation_apply_normalForm, liftDerivation_apply_normalForm, + coefficientDerivation_commute E F hEF] + + +end +end AlgebraicAnalysis.OreTower diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/Polynomial/DistinguishedVariable.lean b/LeanPool/Stafford38/AlgebraicAnalysis/Polynomial/DistinguishedVariable.lean new file mode 100644 index 0000000000..b28dd1de90 --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/Polynomial/DistinguishedVariable.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.MvPolynomial.Variables +import Mathlib.RingTheory.Ideal.Prime +import Mathlib.RingTheory.MvPolynomial.Homogeneous +import Mathlib.RingTheory.MvPolynomial.Ideal + +/-! +# A distinguished variable in a homogeneous prime relation + +If a homogeneous polynomial uses one distinguished variable together with a +set of auxiliary variables, then subtracting its pure distinguished monomial +puts it in the ideal generated by the auxiliary variables. Consequently, a +prime containing the polynomial and every auxiliary variable also contains +the distinguished variable, provided the pure coefficient is a unit. +-/ + +namespace AlgebraicAnalysis.MvPolynomial + +open scoped BigOperators + +variable {R σ : Type*} [CommRing R] + +/-- Removing the pure distinguished monomial from a homogeneous polynomial +leaves an element of the ideal generated by its other allowed variables. -/ +theorem sub_pureMonomial_mem_span_X + {P : MvPolynomial σ R} {N : ℕ} {t : σ} {s : Set σ} {c : R} + (hP : P.IsHomogeneous N) + (hvars : (P.vars : Set σ) ⊆ insert t s) + (hcoeff : P.coeff (Finsupp.single t N) = c) : + P - MvPolynomial.monomial (Finsupp.single t N) c ∈ + Ideal.span (MvPolynomial.X '' s : Set (MvPolynomial σ R)) := by + classical + rw [MvPolynomial.mem_ideal_span_X_image] + intro m hm + by_contra haux + push_neg at haux + have hdiff : + MvPolynomial.coeff m + (P - MvPolynomial.monomial (Finsupp.single t N) c) ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + by_cases hmt : m = Finsupp.single t N + · subst m + simp [hcoeff] at hdiff + have hmono : + MvPolynomial.coeff m + (MvPolynomial.monomial (Finsupp.single t N) c) = 0 := by + simp [MvPolynomial.coeff_monomial, Ne.symm hmt] + have hmP : m ∈ P.support := by + apply MvPolynomial.mem_support_iff.mpr + simpa [hmono] using hdiff + have hsupp : m.support ⊆ {t} := by + intro i hi + have hiVars : i ∈ P.vars := + (MvPolynomial.mem_vars i).mpr ⟨m, hmP, hi⟩ + have hiAllowed : i = t ∨ i ∈ s := by + simpa only [Set.mem_insert_iff] using hvars hiVars + rcases hiAllowed with rfl | his + · simp + · exact False.elim ((Finsupp.mem_support_iff.mp hi) (haux i his)) + have hmform : m = Finsupp.single t (m t) := + Finsupp.support_subset_singleton.mp hsupp + have hdegree : m.degree = N := by + rw [Finsupp.degree_eq_weight_one] + exact hP (MvPolynomial.mem_support_iff.mp hmP) + rw [hmform, Finsupp.degree_single] at hdegree + exact hmt (by rw [hmform, hdegree]) + +/-- A prime containing a homogeneous relation, all auxiliary +variables, and a unit pure coefficient must contain the distinguished +variable. -/ +theorem X_mem_of_homogeneous_mem_prime + {P : MvPolynomial σ R} {N : ℕ} {t : σ} {s : Set σ} {c : R} + (hP : P.IsHomogeneous N) + (hvars : (P.vars : Set σ) ⊆ insert t s) + (hcoeff : P.coeff (Finsupp.single t N) = c) + (hc : IsUnit c) + {p : Ideal (MvPolynomial σ R)} (hp : p.IsPrime) + (hPmem : P ∈ p) + (hsmem : ∀ i ∈ s, MvPolynomial.X i ∈ p) : + MvPolynomial.X t ∈ p := by + have hdiff : + P - MvPolynomial.monomial (Finsupp.single t N) c ∈ p := + (Ideal.span_le.mpr (by + rintro _ ⟨i, hi, rfl⟩ + exact hsmem i hi)) + (sub_pureMonomial_mem_span_X hP hvars hcoeff) + have hmono : MvPolynomial.monomial (Finsupp.single t N) c ∈ p := by + have := p.sub_mem hPmem hdiff + simpa only [sub_sub_cancel] using this + rw [← MvPolynomial.C_mul_X_pow_eq_monomial] at hmono + have hC : IsUnit (MvPolynomial.C c : MvPolynomial σ R) := + hc.map (MvPolynomial.C : R →+* MvPolynomial σ R) + have hpow : MvPolynomial.X t ^ N ∈ p := + (p.unit_mul_mem_iff_mem hC).mp hmono + exact hp.mem_of_pow_mem N hpow + + +end AlgebraicAnalysis.MvPolynomial diff --git a/LeanPool/Stafford38/AlgebraicAnalysis/RingTheory/TwoGeneratorIdentity.lean b/LeanPool/Stafford38/AlgebraicAnalysis/RingTheory/TwoGeneratorIdentity.lean new file mode 100644 index 0000000000..3f5f365fdd --- /dev/null +++ b/LeanPool/Stafford38/AlgebraicAnalysis/RingTheory/TwoGeneratorIdentity.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.OreLocalization.Ring +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightLocalization + +/-! +# Two-generator identities and unit-denominator transport + +This neutral module extracts the reusable algebraic kernel formerly declared as +`Stafford38.LocalizationCorollaries.S38`, +`Stafford38.LocalizationCorollaries.s38_of_rightClearing`, and +`Stafford38.LocalizationCorollaries.s38_of_leftUnitClearing`. + +Source record: Stafford38 commit `1585e4c7`, originally +`Stafford38/LocalizationCorollaries.lean` and +`Stafford38/LeftDenominatorTransport.lean`. +The extracted declarations are application-independent; Stafford38-specific +names and imports are intentionally absent. The written multiplication order +is preserved. +-/ + +namespace AlgebraicAnalysis + +universe u v + +/-- The two-generator identity in a ring, with the distinguished factor on +the left of the first product and in the middle of the second. -/ +def TwoGeneratorIdentity (R : Type u) [Ring R] : Prop := + ∀ d : R, d ≠ 0 → ∃ F r s : R, (1 : R) = d * r + F * d * s + +/-- Right-clearing transport of the two-generator identity. -/ +theorem TwoGeneratorIdentity.of_rightUnitClearing + {R : Type u} {L : Type v} [Ring R] [Ring L] + {f : R →+* L} (hR : TwoGeneratorIdentity R) + (hclear : ∀ q : L, q ≠ 0 → + ∃ a s : R, IsUnit (f s) ∧ q * f s = f a) : + TwoGeneratorIdentity L := by + intro q hq + rcases hclear q hq with ⟨a, s, hs, hqa⟩ + have ha : a ≠ 0 := by + intro ha + have hzero : q * f s = 0 := by simpa [ha] using hqa + exact hq (hs.mul_right_cancel (by simpa using hzero)) + rcases hR a ha with ⟨F, r, t, hone⟩ + refine ⟨f F, f s * f r, f s * f t, ?_⟩ + have hm := congrArg f hone + simp only [map_add, map_mul] at hm + calc + (1 : L) = f a * f r + f F * f a * f t := by simpa using hm + _ = q * (f s * f r) + f F * q * (f s * f t) := by + rw [← hqa] + simp [mul_assoc] + +/-- Left-clearing transport of the two-generator identity. -/ +theorem TwoGeneratorIdentity.of_leftUnitClearing + {R : Type u} {L : Type v} [Ring R] [Ring L] + {f : R →+* L} (hR : TwoGeneratorIdentity R) + (hclear : ∀ q : L, q ≠ 0 → + ∃ a : R, ∃ u : L, IsUnit u ∧ u * q = f a) : + TwoGeneratorIdentity L := by + intro q hq + rcases hclear q hq with ⟨a, u, hu, hqa⟩ + have ha : a ≠ 0 := by + intro ha + have hzero : u * q = 0 := by simpa [ha] using hqa + exact hq (hu.mul_left_cancel (by simpa using hzero)) + rcases hR a ha with ⟨F, r, t, hone⟩ + let U : Lˣ := hu.unit + let ui : L := U.inv + have hui : ui * u = 1 := by + dsimp [ui, U] + exact U.inv_mul + have hui' : u * ui = 1 := by + dsimp [ui, U] + exact U.val_inv + refine ⟨ui * f F * u, f r * u, f t * u, ?_⟩ + have hm := congrArg f hone + simp only [map_add, map_mul] at hm + have hm' : (1 : L) = (u * q) * f r + f F * (u * q) * f t := by + simpa [hqa] using hm + have hm'' := congrArg (fun z : L => ui * z * u) hm' + have hm''' : (1 : L) = ui * ((u * q) * f r + f F * (u * q) * f t) * u := by + simpa [hui, mul_assoc] using hm'' + calc + (1 : L) = ui * ((u * q) * f r + f F * (u * q) * f t) * u := hm''' + _ = q * (f r * u) + (ui * f F * u) * q * (f t * u) := by + simp only [mul_add, add_mul, ← mul_assoc, hui, one_mul] + +/-- The two-generator identity is preserved by the right Ore localization +implemented through the opposite ring. -/ +theorem TwoGeneratorIdentity.of_rightOreLocalization + {R : Type u} [Ring R] {S : Submonoid R} + [OreLocalization.OreSet + (AlgebraicAnalysis.OreRightLocalization.oppositeSubmonoid S)] + (hR : TwoGeneratorIdentity R) : + TwoGeneratorIdentity + (AlgebraicAnalysis.OreRightLocalization.RightOreLocalization R S) := by + apply TwoGeneratorIdentity.of_rightUnitClearing hR + intro q hq + rcases AlgebraicAnalysis.OreRightLocalization.rightOre_clear (S := S) q with + ⟨a, s, _, hs, hclear⟩ + exact ⟨a, s, hs, hclear⟩ + +end AlgebraicAnalysis diff --git a/LeanPool/Stafford38/FixedSourceSolution.lean b/LeanPool/Stafford38/FixedSourceSolution.lean new file mode 100644 index 0000000000..a74b50b4b6 --- /dev/null +++ b/LeanPool/Stafford38/FixedSourceSolution.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.FoundationClosure +import LeanPool.Stafford38.Stafford38.FixedSourceChallengeTransport + +/-! +# Solution for the exact-source challenge + +The substantive development proves the exact fixed-source theorem on the same +`RingQuot` presentation of the Weyl algebra +(`Stafford38.universalFixedSourceStatement`). The transport module identifies +the challenge's intrinsic ordered-word filtration and its least-level degree +with the development's checked PBW normal-form filtration and degree, and the +two linear symplectic coordinate predicates are definitionally equal. This +file only combines those facts; it adds no hypothesis and supplies no degree +or normal-form datum. +-/ + +namespace Stafford38FixedSourceChallenge + +universe u + +theorem universalFixedSourceStatement : UniversalFixedSourceStatement := by + intro k _ _ n d hd + obtain ⟨ell, R, S, hell, hcert⟩ := + Stafford38.universalFixedSourceStatement (k := k) n d hd + have hdeg := Stafford38FixedSourceChallengeTransport.bernsteinDegree_eq k d + refine ⟨ell, R, S, + (Stafford38FixedSourceChallengeTransport.isLinearWeylCoordinate_iff + k n ell).mpr hell, ?_⟩ + rw [hdeg] + exact hcert + +end Stafford38FixedSourceChallenge diff --git a/LeanPool/Stafford38/Solution.lean b/LeanPool/Stafford38/Solution.lean new file mode 100644 index 0000000000..b1fbc6180e --- /dev/null +++ b/LeanPool/Stafford38/Solution.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.FoundationClosure + +namespace Stafford38Challenge + +abbrev PhaseVar (n : ℕ) := Fin n ⊕ Fin n + +def relation {k : Type*} [Field k] {n : ℕ} + (omega : Matrix (PhaseVar n) (PhaseVar n) k) + (a b : FreeAlgebra k (PhaseVar n)) : Prop := + ∃ i j, + a = FreeAlgebra.ι k i * FreeAlgebra.ι k j - + FreeAlgebra.ι k j * FreeAlgebra.ι k i ∧ + b = algebraMap k (FreeAlgebra k (PhaseVar n)) (omega i j) + +abbrev WeylAlg (k : Type*) [Field k] (n : ℕ) := + RingQuot (relation (k := k) (n := n) (Matrix.J (Fin n) k)) + +def UniversalStatement : Prop := + ∀ (k : Type*) [Field k] [CharZero k] (n : ℕ) (d : WeylAlg k n), + d ≠ 0 → ∃ F R S : WeylAlg k n, (1 : WeylAlg k n) = d * R + F * d * S + +private def toSubstantive (k : Type*) [Field k] (n : ℕ) : + WeylAlg k n ≃ₐ[k] Stafford38.WeylAlg k n := + AlgEquiv.refl + +theorem universalStatement : UniversalStatement := by + intro k _ _ n d hd + let e := toSubstantive k n + have hsd : e d ≠ 0 := by + intro h + apply hd + apply e.injective + simpa using h + rcases Stafford38.universalStatement (k := k) n (e d) hsd with ⟨F, R, S, h⟩ + refine ⟨e.symm F, e.symm R, e.symm S, ?_⟩ + simpa using congrArg e.symm h + +end Stafford38Challenge diff --git a/LeanPool/Stafford38/Stafford38.lean b/LeanPool/Stafford38/Stafford38.lean new file mode 100644 index 0000000000..9f8d8149e4 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.FoundationClosure +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialCorollaries +import LeanPool.Stafford38.Stafford38.LocalizationCorollaries +import LeanPool.Stafford38.Stafford38.LeftHandedCorollary +import LeanPool.Stafford38.Stafford38.EvolutionaryCorollary +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticConormal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSets +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter +import LeanPool.Stafford38.Stafford38.Geometry.GeneralComponentConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterion +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLatticePresentation +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSetsTest +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterionTest + +/-! Stafford theorem, advertised corollaries, and independent geometry consumers. -/ diff --git a/LeanPool/Stafford38/Stafford38/CanonicalSupportVanishingReduction.lean b/LeanPool/Stafford38/Stafford38/CanonicalSupportVanishingReduction.lean new file mode 100644 index 0000000000..03228ed4e5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/CanonicalSupportVanishingReduction.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.UniversalAssembly +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitCoordinatePreimage +import LeanPool.Stafford38.Stafford38.Geometry.ConormalAxisContradiction +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection + +/-! +# Conditional Laurent-direction skeleton for canonical support vanishing + +This file retains a conditional Laurent-direction assembly between the literal +canonical quotient and `CanonicalSupportVanishing`. Its interfaces are +discharged downstream; they do not mark gaps in the unconditional theorem. +Over an algebraically +closed field, one order-zero coordinate predecessor of the unit supplies axis +avoidance, a Gabber/scalar-extension input makes the canonical fibre symbol +vanish on the Laurent equation-conormal locus, and the asymptotic producer supplies a +Laurent-generic conormal whose regular fibre residue is the forbidden pure +momentum direction. A fourth input explicitly isolates descent from algebraic +closure back to an arbitrary characteristic-zero field. + +No finite phase-space limit is asserted: the Laurent base coordinates may have +poles, and only the fibre residue is specialized. +-/ + +namespace Stafford38.CanonicalSupportVanishingReduction + +open Stafford38 +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.CanonicalUnitCoordinatePreimage +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ConormalAxisContradiction +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +/-- Universal production of strict filtered coordinate cancellation for the +literal canonical quotient. -/ +def CanonicalCoordinateCancellation : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + CoordinateCancellation k n N d + +/-- Universal production of the weakest filtered input used by terminal axis +avoidance: one order-zero coordinate predecessor of the quotient unit. -/ +def CanonicalStrictUnitCoordinatePreimage : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + StrictUnitCoordinatePreimage k n N d + +/-- The pure momentum axis in the fibre-coordinate space. -/ +def pureMomentumFibreAxis (k : Type u) [Field k] (n : ℕ) : + Fin (n + 1) → k := + fun i ↦ if i = 0 then 1 else 0 + +/-- Packaged Laurent symbol control from Gabber, scalar extension, fibre-only +symbol extraction, and the checked conormal containment. -/ +def CanonicalLaurentSymbolControl : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + ∃ P : MvPolynomial (Fin (n + 1)) k, + fibreLift P = presentedPrincipalComponent k orderWeight N d ∧ + ∀ q ∈ equationConormalLocus + ((reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin (n + 1)))), + MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) q + (fibreLift P) = 0 + +/-- The remaining global geometric producer. Its base coordinates stay in +Laurent series; only its regular fibre covector specializes to the pure +momentum axis. -/ +def CanonicalAsymptoticLaurentProducer : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)).Nonempty → + ∃ (y : Fin (n + 1) → LaurentSeries k) + (xi : Fin (n + 1) → PowerSeries k), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + ((reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin (n + 1)))) ∧ + residueColumn xi = pureMomentumFibreAxis k n + +/-- Canonical support vanishing restricted to algebraically closed +characteristic-zero fields. -/ +def AlgebraicallyClosedCanonicalSupportVanishing : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) = ∅ + +/-- The still-separate Weyl/base-change descent theorem. This input must be +proved by transporting the canonical quotient and its initial ideal through +algebraic closure; geometric support descent alone does not supply it. -/ +def CanonicalSupportDescent : Prop := + AlgebraicallyClosedCanonicalSupportVanishing.{u} → + Stafford38.UniversalAssembly.CanonicalSupportVanishing.{u} + +/-- The conditional contradiction skeleton over algebraically closed fields. +Its asymptotic input must be proved from divisor geometry without using the +desired support-vanishing conclusion. -/ +theorem algebraicallyClosedCanonicalSupportVanishing_of_three_inputs + (hunit : CanonicalStrictUnitCoordinatePreimage.{u}) + (hcontrol : CanonicalLaurentSymbolControl.{u}) + (hasymptotic : CanonicalAsymptoticLaurentProducer.{u}) : + AlgebraicallyClosedCanonicalSupportVanishing.{u} := by + intro k _ _ _ n N d hN hd + let I := canonicalRightIdeal (presentedCoordinate k n) d N + have hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + exact + canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus_of_strictUnit + k n N (hunit k n N d hN hd) + by_contra hsupp + have hnonempty : (orderCharacteristicSupport k I).Nonempty := + Set.nonempty_iff_ne_empty.mpr hsupp + rcases hcontrol k n N d hN hd with ⟨P, hP, hvanishes⟩ + rcases hasymptotic k n N d hN hd hdisjoint hnonempty with + ⟨y, xi, hgeneric, hresidue⟩ + apply false_of_fibreOnly_symbol_one_on_residue_and_vanishes_on_laurentConormal + (reducedOrderBaseIdeal k I) P (pureMomentumFibreAxis k n) y xi + hgeneric hresidue hvanishes + have hcanonical := canonical_orderPrincipalComponent_eval_pureMomentumAxis + n N hd + have hsplit : Sum.elim (fun _ : Fin (n + 1) ↦ (0 : k)) + (pureMomentumFibreAxis k n) = + axisPoint k (.inr (0 : Fin (n + 1))) := by + funext i + rcases i with i | i + · simp [axisPoint] + · simp [axisPoint, pureMomentumFibreAxis] + rw [← hP] at hcanonical + have heval := eval₂_fibreLift (K := k) P + (fun _ : Fin (n + 1) ↦ (0 : k)) (pureMomentumFibreAxis k n) + rw [hsplit] at heval + simpa only [← MvPolynomial.aeval_def, MvPolynomial.aeval_eq_eval] using + heval.symm.trans hcanonical + +/-- Consequently the exact Stafford statement follows from the three +algebraically closed inputs and the separate support-descent theorem. -/ +theorem universalStatement_of_four_inputs + (hunit : CanonicalStrictUnitCoordinatePreimage.{u}) + (hcontrol : CanonicalLaurentSymbolControl.{u}) + (hasymptotic : CanonicalAsymptoticLaurentProducer.{u}) + (hdescent : CanonicalSupportDescent.{u}) : + Stafford38.UniversalStatement.{u} := + Stafford38.UniversalAssembly.universalStatement_of_canonicalSupportVanishing + (hdescent + (algebraicallyClosedCanonicalSupportVanishing_of_three_inputs + hunit hcontrol hasymptotic)) + + +end + +end Stafford38.CanonicalSupportVanishingReduction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisExistence.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisExistence.lean new file mode 100644 index 0000000000..cad11cc768 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisExistence.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +import Mathlib.Data.Fintype.Sort +import Mathlib.Data.Prod.Lex + +/-! +# Existence of filtration-adapted bases + +This file constructs a basis adapted to a finite descending filtration of a +finite-dimensional vector space. The construction is elementary: starting +at a zero layer, extend a linearly independent set one layer at a time, and +label each newly added vector by the layer at which it appears. A final +sorting by decreasing labels gives the ordered `Fin` basis used by the +Artinian trace argument. +-/ + +namespace Stafford38.Characteristic.ArtinianAdaptedBasisExistence + +open Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter + +noncomputable section + +universe u + +section LinearFiltration + +variable {K V : Type u} [Field K] [AddCommGroup V] [Module K V] + +/-- Intermediate set-valued form of an adapted basis, valid from `start` +onwards. -/ +private structure PartialAdaptedSet + (F : ℕ → Submodule K V) (start : ℕ) where + carrier : Set V + independent : LinearIndependent K ((↑) : carrier → V) + span_start : Submodule.span K carrier = F start + level : carrier → ℕ + start_le_level : ∀ i, start ≤ level i + span_level : ∀ t, start ≤ t → + F t = Submodule.span K (((↑) : carrier → V) '' {i | t ≤ level i}) + +private noncomputable def partialAtBottom + (F : ℕ → Submodule K V) (hanti : Antitone F) + (N : ℕ) (hN : F N = ⊥) : + PartialAdaptedSet F N := by + refine + { carrier := ∅ + independent := linearIndependent_empty K V + span_start := by simp [hN] + level := fun i => False.elim i.property + start_le_level := fun i => False.elim i.property + span_level := ?_ } + intro t hNt + have ht : F t = ⊥ := by + apply le_bot_iff.mp + rw [← hN] + exact hanti hNt + have hempty : {i : (∅ : Set V) | t ≤ False.elim i.property} = ∅ := by + ext i + exact False.elim i.property + simp [ht, hempty] + +private noncomputable def partialStep + (F : ℕ → Submodule K V) (hanti : Antitone F) + (t : ℕ) (old : PartialAdaptedSet F (t + 1)) : + PartialAdaptedSet F t := by + classical + let oldIn : old.carrier ⊆ (F t : Set V) := fun x hx => + hanti (Nat.le_succ t) (by + rw [← old.span_start] + exact Submodule.subset_span hx) + have hOld : LinearIndepOn K id old.carrier := + linearIndependent_subtype_iff.mp old.independent + let next : Set V := hOld.extend oldIn + have holdNext : old.carrier ⊆ next := + hOld.subset_extend oldIn + have hnextF : next ⊆ (F t : Set V) := + hOld.extend_subset oldIn + have hind : LinearIndependent K ((↑) : next → V) := by + exact linearIndependent_subtype_iff.mpr + (hOld.linearIndepOn_extend oldIn) + let lev : next → ℕ := fun i => + if hi : (i : V) ∈ old.carrier then old.level ⟨i, hi⟩ else t + have hlev : ∀ i, t ≤ lev i := by + intro i + dsimp [lev] + split_ifs with hi + · exact le_trans (Nat.le_succ t) (old.start_le_level ⟨i, hi⟩) + · exact le_rfl + refine + { carrier := next + independent := hind + span_start := ?_ + level := lev + start_le_level := hlev + span_level := ?_ } + · apply le_antisymm + · exact Submodule.span_le.mpr hnextF + · exact hOld.subset_span_extend oldIn + · intro u htu + rcases Nat.eq_or_lt_of_le htu with rfl | htu' + · have hall : (((↑) : next → V) '' {i | t ≤ lev i}) = next := by + ext x + constructor + · rintro ⟨i, -, rfl⟩ + exact i.property + · intro hx + exact ⟨⟨x, hx⟩, hlev ⟨x, hx⟩, rfl⟩ + rw [hall] + symm + apply le_antisymm + · exact Submodule.span_le.mpr hnextF + · exact hOld.subset_span_extend oldIn + · rw [old.span_level u (Nat.succ_le_iff.mpr htu')] + apply congrArg (Submodule.span K) + ext x + constructor + · rintro ⟨i, hi, rfl⟩ + let j : next := ⟨(i : V), holdNext i.property⟩ + refine ⟨j, ?_, rfl⟩ + simpa [lev, j, i.property] using hi + · rintro ⟨i, hi, rfl⟩ + have hiOld : (i : V) ∈ old.carrier := by + by_contra hn + have : lev i = t := dif_neg hn + change u ≤ lev i at hi + rw [this] at hi + exact (Nat.not_le_of_lt htu') hi + refine ⟨⟨(i : V), hiOld⟩, ?_, rfl⟩ + simpa [lev, hiOld] using hi + +private noncomputable def partialAtZero + (F : ℕ → Submodule K V) (hanti : Antitone F) + (N : ℕ) (hN : F N = ⊥) : + PartialAdaptedSet F 0 := + Nat.decreasingInduction + (motive := fun t _ => PartialAdaptedSet F t) + (fun t _ old => partialStep F hanti t old) + (partialAtBottom F hanti N hN) + (Nat.zero_le N) + +/-- Every finite descending filtration of a finite-dimensional vector space +has a `Fin`-indexed basis ordered by decreasing filtration level. -/ +theorem exists_filtrationAdaptedBasis + [FiniteDimensional K V] + {n : ℕ} (hdim : Module.finrank K V = n + 1) + (F : ℕ → Submodule K V) + (hanti : Antitone F) + (hzero : F 0 = ⊤) + (heventually : ∃ N, F N = ⊥) : + ∃ (b : Module.Basis (Fin (n + 1)) K V) (level : Fin (n + 1) → ℕ), + Antitone level ∧ + ∀ t, F t = Submodule.span K (b '' {i | t ≤ level i}) := by + classical + obtain ⟨N, hN⟩ := heventually + let data := partialAtZero F hanti N hN + have hspanTop : Submodule.span K data.carrier = ⊤ := data.span_start.trans hzero + let raw : Module.Basis data.carrier K V := + Module.Basis.mk data.independent (by simpa using hspanTop.ge) + letI : Fintype data.carrier := FiniteDimensional.fintypeBasisIndex raw + have hcard : Fintype.card data.carrier = n + 1 := by + rw [← hdim, ← Module.finrank_eq_card_basis raw] + let rank : data.carrier ≃ Fin (n + 1) := + Fintype.equivOfCardEq (hcard.trans (Fintype.card_fin (n + 1)).symm) + let key : data.carrier → (OrderDual ℕ ×ₗ Fin (n + 1)) := + fun i => toLex ((data.level i : OrderDual ℕ), rank i) + have hkey : Function.Injective key := by + intro i j hij + apply rank.injective + exact congrArg (fun z => (ofLex z).2) hij + letI : LinearOrder data.carrier := LinearOrder.lift' key hkey + let sorted : Fin (n + 1) ≃o data.carrier := + Fintype.orderIsoFinOfCardEq data.carrier hcard + let b : Module.Basis (Fin (n + 1)) K V := raw.reindex sorted.toEquiv.symm + let level : Fin (n + 1) → ℕ := fun i => data.level (sorted i) + refine ⟨b, level, ?_, ?_⟩ + · intro i j hij + have hs : sorted i ≤ sorted j := sorted.monotone hij + have hs' : key (sorted i) ≤ key (sorted j) := hs + rw [Prod.Lex.toLex_le_toLex] at hs' + rcases hs' with hs | ⟨hs, -⟩ + · exact Nat.le_of_lt hs + · exact le_of_eq (congrArg OrderDual.ofDual hs).symm + · intro t + rw [data.span_level t (Nat.zero_le t)] + congr 1 + ext x + constructor + · rintro ⟨i, hi, rfl⟩ + refine ⟨sorted.symm i, ?_, ?_⟩ + · simpa [level] using hi + · simp [b, raw] + · rintro ⟨i, hi, rfl⟩ + refine ⟨sorted i, ?_, ?_⟩ + · simpa [level] using hi + · simp [b, raw] + +end LinearFiltration + +section ArtinianApplication + +variable {K R V : Type u} +variable [Field K] [CommRing R] [Algebra K R] [IsLocalRing R] +variable [IsArtinianRing R] +variable [AddCommGroup V] [Module K V] [Module R V] [IsScalarTower K R V] +variable [FiniteDimensional K V] + +local notation "𝔪" => IsLocalRing.maximalIdeal R + +/-- Maximal-ideal powers on a finite-dimensional module have the adapted +basis required by the Artinian trace adapter. -/ +theorem exists_maximalIdealFiltrationAdaptedBasis + {n : ℕ} (hdim : Module.finrank K V = n + 1) : + ∃ (b : Module.Basis (Fin (n + 1)) K V) (level : Fin (n + 1) → ℕ), + IsMaximalIdealFiltrationAdapted 𝔪 b level := by + let F : ℕ → Submodule K V := fun t => + ((𝔪 ^ t • (⊤ : Submodule R V)).restrictScalars K) + have hanti : Antitone F := by + intro a b hab + exact (Submodule.restrictScalarsEmbedding K R V).monotone + (Submodule.smul_mono (Ideal.pow_le_pow_right hab) le_rfl) + have hzero : F 0 = ⊤ := by + ext v + simp [F] + obtain ⟨N, hN⟩ := + Stafford38.Characteristic.ArtinianCoefficientField.maximalIdeal_isNilpotent + (R := R) + have hbottom : F N = ⊥ := by + ext v + simp [F, hN] + obtain ⟨b, level, hlevel, hspan⟩ := + exists_filtrationAdaptedBasis hdim F hanti hzero ⟨N, hbottom⟩ + exact ⟨b, level, ⟨hlevel, hspan⟩⟩ + + +end ArtinianApplication + +end + +end Stafford38.Characteristic.ArtinianAdaptedBasisExistence diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisTraceAdapter.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisTraceAdapter.lean new file mode 100644 index 0000000000..c9674ac6c9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianAdaptedBasisTraceAdapter.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianTriangularTrace +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianCoefficientField +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLinearTrace +import Mathlib.LinearAlgebra.Basis.Basic +import Mathlib.RingTheory.Artinian.Module +import Mathlib.RingTheory.LocalRing.Module + +/-! +# Adapted bases and square-zero quotient descent + +This file formalizes elementary inputs used near Singh--Kumar Proposition 3.2. +The special fibre is a finite-dimensional module over a commutative Artinian +local algebra. A basis adapted to the powers of the maximal ideal makes left +multiplication by a maximal-ideal element strictly upper triangular. + +The square-zero exactness hypothesis is used at the precise point where the +paper uses `cM = Ann_M(c)`: an equality after multiplication by `c` descends +to equality of the induced operators on `M / cM`. + +The scalar-plus-maximal-ideal decomposition is converted to a matrix identity. +The final theorem is only a conditional assembler: its matrix-decomposition +hypothesis already implies trace zero. It is not a formalization of equation +(3.3), and neither `q = 0` nor the concrete deformation-ring/right-Rees +adapter is proved here. +-/ + +namespace Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter + +open Matrix +open Stafford38.Characteristic.ArtinianTriangularTrace +open Stafford38.Characteristic.SquareZeroLinearTrace + +noncomputable section + +universe u + +section AdaptedBasis + +variable {K R V : Type u} +variable [Field K] [CommRing R] [Algebra K R] [IsLocalRing R] +variable [AddCommGroup V] [Module K V] [Module R V] [IsScalarTower K R V] +variable {n : ℕ} + +local notation "𝔪" => IsLocalRing.maximalIdeal R + +/-- Left multiplication on the special-fibre module, viewed as a +`K`-linear endomorphism. -/ +def leftMultiplicationEnd (r : R) : Module.End K V where + toFun v := r • v + map_add' := smul_add r + map_smul' a v := by exact smul_comm r a v + +omit [IsLocalRing R] in +@[simp] theorem leftMultiplicationEnd_apply (r : R) (v : V) : + leftMultiplicationEnd (K := K) (V := V) r v = r • v := rfl + +/-- A basis genuinely adapted to the maximal-ideal-power filtration. + +`level i` records the last filtration layer containing `b i`. The ordering +condition says deeper vectors occur earlier, as in the basis construction in +Proposition 3.2. The second field identifies every power-filtration layer +with the span of the corresponding basis vectors. -/ +structure IsMaximalIdealFiltrationAdapted + (m : Ideal R) + (b : Module.Basis (Fin (n + 1)) K V) (level : Fin (n + 1) → ℕ) : Prop where + antitone_level : Antitone level + power_span : ∀ t : ℕ, + ((m ^ t • (⊤ : Submodule R V)).restrictScalars K) = + Submodule.span K (b '' {i | t ≤ level i}) + +/-- Multiplication by a maximal-ideal element raises the power filtration by +one. -/ +lemma maximalIdeal_smul_mem_succ_power + {r : R} (hr : r ∈ 𝔪) {t : ℕ} {v : V} + (hv : v ∈ 𝔪 ^ t • (⊤ : Submodule R V)) : + r • v ∈ 𝔪 ^ (t + 1) • (⊤ : Submodule R V) := by + refine Submodule.smul_induction_on + (p := fun v => r • v ∈ 𝔪 ^ (t + 1) • (⊤ : Submodule R V)) hv ?_ ?_ + · intro (a : R) ha w hw + rw [smul_smul] + apply Submodule.smul_mem_smul + · rw [pow_succ'] + exact Ideal.mul_mem_mul hr ha + · exact Submodule.mem_top + · intro x y hx hy + rw [smul_add] + exact Submodule.add_mem _ hx hy + +/-- The left multiplication matrix of a maximal-ideal element is strictly +upper triangular in a maximal-ideal-filtration adapted basis. -/ +theorem leftMultiplicationMatrix_isStrictUpperTriangular + (b : Module.Basis (Fin (n + 1)) K V) (level : Fin (n + 1) → ℕ) + (hadapted : IsMaximalIdealFiltrationAdapted 𝔪 b level) + {r : R} (hr : r ∈ 𝔪) : + IsStrictUpperTriangular + (LinearMap.toMatrix b b (leftMultiplicationEnd (K := K) (V := V) r)) := by + intro i j hji + rw [LinearMap.toMatrix_apply] + have hbjSpan : + b j ∈ Submodule.span K (b '' {i | level j ≤ level i}) := by + exact (b.self_mem_span_image).mpr (show level j ≤ level j from le_rfl) + have hbjPower : b j ∈ 𝔪 ^ level j • (⊤ : Submodule R V) := by + have := hbjSpan + rw [← hadapted.power_span (level j)] at this + exact this + have hraised : + r • b j ∈ 𝔪 ^ (level j + 1) • (⊤ : Submodule R V) := + maximalIdeal_smul_mem_succ_power hr hbjPower + have hspan : + r • b j ∈ Submodule.span K (b '' {i | level j + 1 ≤ level i}) := by + rw [← hadapted.power_span (level j + 1)] + exact hraised + have hsupp := b.repr_support_subset_of_mem_span + {i | level j + 1 ≤ level i} hspan + by_contra hne + have hiSupport : i ∈ (b.repr (r • b j)).support := Finsupp.mem_support_iff.mpr hne + have hlevel : level j + 1 ≤ level i := hsupp hiSupport + have hreverse : level i ≤ level j := hadapted.antitone_level hji + omega + +/-- In the Artinian-local case, the matrix of multiplication by a +maximal-ideal element is nilpotent. -/ +theorem leftMultiplicationMatrix_isNilpotent + [IsArtinianRing R] + (b : Module.Basis (Fin (n + 1)) K V) {r : R} (hr : r ∈ 𝔪) : + IsNilpotent + (LinearMap.toMatrix b b (leftMultiplicationEnd (K := K) (V := V) r)) := by + have hrnil : IsNilpotent r := by + obtain ⟨N, hN⟩ := + Stafford38.Characteristic.ArtinianCoefficientField.maximalIdeal_isNilpotent + (R := R) + refine ⟨N, ?_⟩ + have hrpow : r ^ N ∈ 𝔪 ^ N := Ideal.pow_mem_pow hr N + rw [hN] at hrpow + exact hrpow + have hend : IsNilpotent (leftMultiplicationEnd (K := K) (V := V) r) := by + obtain ⟨N, hN⟩ := hrnil + refine ⟨N, ?_⟩ + ext v + have hp : ∀ (j : ℕ) (w : V), + ((leftMultiplicationEnd (K := K) (V := V) r) ^ j) w = r ^ j • w := by + intro j + induction j with + | zero => intro w; simp + | succ j ih => + intro w + rw [pow_succ, Module.End.mul_apply, ih, leftMultiplicationEnd_apply] + exact (SemigroupAction.mul_smul (r ^ j) r w).symm.trans (by rw [pow_succ]) + rw [hp N v, hN, zero_smul, LinearMap.zero_apply] + exact hend.map (LinearMap.toMatrixAlgEquiv b) + +/-- Matrix form of equation (3.1): the coefficient-field scalar contributes +`q I`, and the maximal-ideal remainder contributes its multiplication +matrix. -/ +theorem leftMultiplicationMatrix_decomposition + (b : Module.Basis (Fin (n + 1)) K V) (q : K) (r z : R) + (hz : z = algebraMap K R q + r) : + LinearMap.toMatrix b b (leftMultiplicationEnd (K := K) (V := V) z) = + q • (1 : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + + LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) r) := by + subst z + have hend : + leftMultiplicationEnd (K := K) (V := V) (algebraMap K R q + r) = + q • LinearMap.id + leftMultiplicationEnd (K := K) (V := V) r := by + ext v + simp [leftMultiplicationEnd, add_smul, IsScalarTower.algebraMap_smul] + rw [hend, (LinearMap.toMatrix b b).map_add, + (LinearMap.toMatrix b b).map_smul] + simp + +end AdaptedBasis + +section SquareZeroDescent + +variable {K W : Type u} [Field K] +variable [AddCommGroup W] [Module K W] +variable {n : ℕ} + +/-- Square-zero exactness descends an equality after multiplication by the +parameter to equality of the induced special-fibre operators. + +This is the exact square-zero quotient bridge: from +`C ∘ Z = C ∘ T` and `ker C = range C`, the actions of `Z` and `T` agree on +`W / range C`. -/ +theorem quotientEnd_eq_of_parameter_comp_eq + (C Z T : Module.End K W) + (hExact : LinearMap.ker C = LinearMap.range C) + (hZC : Z.comp C = C.comp Z) + (hTC : T.comp C = C.comp T) + (hparameter : C.comp Z = C.comp T) : + quotientEnd C Z hZC = quotientEnd C T hTC := by + apply LinearMap.ext + intro q + obtain ⟨w, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) q + apply (Submodule.Quotient.eq (LinearMap.range C)).mpr + rw [← hExact, LinearMap.mem_ker] + change C (Z w - T w) = 0 + rw [map_sub, sub_eq_zero] + exact LinearMap.congr_fun hparameter w + +/-- A signed sum of three matrices that will be used only in the conditional +matrix assembler below. -/ +def strictTriangularSignedSum + (X Y Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + X - Y + Γ + +/-- A signed sum of strictly upper-triangular matrices is strictly upper +triangular. -/ +theorem strictTriangularSignedSum_isStrictUpperTriangular + (X Y Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hX : IsStrictUpperTriangular X) + (hY : IsStrictUpperTriangular Y) + (hΓ : IsStrictUpperTriangular Γ) : + IsStrictUpperTriangular (strictTriangularSignedSum X Y Γ) := by + intro i j hji + simp [strictTriangularSignedSum, hX i j hji, hY i j hji, hΓ i j hji] + +/-- Conditional trace assembler for a supplied matrix decomposition. + +The actual basis is on the special fibre `W / range C`. Source-specific +upstream data has already produced the strict upper-triangular remainder +`R₀`; `hdecomposition` assumes that the corrected quotient operator is a +strictly triangular matrix plus commutators. This hypothesis already carries +the trace-zero content and is not claimed to follow directly from equation +(3.3). Square-zero exactness only replaces `T` by the quotient action of `Z`. +-/ +theorem adaptedBasis_conditional_trace_assembler + (C Z T : Module.End K W) + (hExact : LinearMap.ker C = LinearMap.range C) + (hZC : Z.comp C = C.comp Z) + (hTC : T.comp C = C.comp T) + (hparameter : C.comp Z = C.comp T) + (b : Module.Basis (Fin (n + 1)) K (W ⧸ LinearMap.range C)) + (R₀ Θ Φ Ψ H : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hR₀ : IsStrictUpperTriangular R₀) + (hdecomposition : + LinearMap.toMatrix b b (quotientEnd C T hTC) = + adaptedFirstOrderMatrix R₀ Θ Φ Ψ H) : + LinearMap.toMatrix b b (quotientEnd C Z hZC) = + adaptedFirstOrderMatrix R₀ Θ Φ Ψ H ∧ + Matrix.trace (LinearMap.toMatrix b b (quotientEnd C Z hZC)) = 0 := by + have hdesc := quotientEnd_eq_of_parameter_comp_eq + C Z T hExact hZC hTC hparameter + constructor + · rw [hdesc] + exact hdecomposition + · rw [hdesc, hdecomposition] + exact trace_adaptedFirstOrderMatrix_eq_zero R₀ Θ Φ Ψ H hR₀ + + +end SquareZeroDescent + +section Proposition32Adapter + +variable {K R V W : Type u} +variable [Field K] [CommRing R] [Algebra K R] [IsLocalRing R] +variable [IsArtinianRing R] +variable [AddCommGroup V] [Module K V] [Module R V] [IsScalarTower K R V] +variable [AddCommGroup W] [Module K W] +variable {n : ℕ} + +local notation "𝔪" => IsLocalRing.maximalIdeal R + +/-- Conditional assembly of adapted-basis data with a supplied trace-zero +matrix decomposition. + +The basis `b`, indexed by the nonempty finite type `Fin (n+1)`, exhibits the +special fibre `V` as nonzero and finite-dimensional over `K`; `V` is also a +module over the commutative Artinian local algebra `R`. Its adaptedness makes +the multiplication matrix `U` of the maximal-ideal remainder in (3.1) +strictly upper triangular, while Artinianness makes `U` nilpotent. This is +kept distinct from the strict triangular correction remainder `Δ` in (3.3). + +The equivalence `e` identifies `V` with the square-zero quotient of the +deformation module. Exactness descends equality of the supplied operators to +the special fibre. The hypothesis `hdecomposition` already presents the +corrected operator as a strictly triangular matrix plus commutators. + +The conclusion packages strictness and nilpotence of the (3.1) remainder, +trace zero conditional on the supplied decomposition, and the +scalar-plus-remainder matrix identity. It does not assume or prove the scalar +conclusion `q = 0`. It does not derive the supplied matrix decomposition from +Singh--Kumar equation (3.3). -/ +theorem adaptedBasis_conditional_terminal_inputs + (b : Module.Basis (Fin (n + 1)) K V) (level : Fin (n + 1) → ℕ) + (hadapted : IsMaximalIdealFiltrationAdapted 𝔪 b level) + (q : K) (r z : R) (hr : r ∈ 𝔪) + (hz : z = algebraMap K R q + r) + (C Z T : Module.End K W) + (hExact : LinearMap.ker C = LinearMap.range C) + (hZC : Z.comp C = C.comp Z) + (hTC : T.comp C = C.comp T) + (hparameter : C.comp Z = C.comp T) + (e : (W ⧸ LinearMap.range C) ≃ₗ[K] V) + (hZaction : + LinearMap.toMatrix (b.map e.symm) (b.map e.symm) + (quotientEnd C Z hZC) = + LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) z)) + (Xcorr Ycorr Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (Θ Φ Ψ H : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hXcorr : IsStrictUpperTriangular Xcorr) + (hYcorr : IsStrictUpperTriangular Ycorr) + (hΓ : IsStrictUpperTriangular Γ) + (hdecomposition : + LinearMap.toMatrix (b.map e.symm) (b.map e.symm) + (quotientEnd C T hTC) = + adaptedFirstOrderMatrix + (strictTriangularSignedSum Xcorr Ycorr Γ) Θ Φ Ψ H) : + IsStrictUpperTriangular + (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) r)) ∧ + IsNilpotent + (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) r)) ∧ + Matrix.trace + (LinearMap.toMatrix (b.map e.symm) (b.map e.symm) + (quotientEnd C Z hZC)) = 0 ∧ + q • (1 : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + + LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) r) = + LinearMap.toMatrix (b.map e.symm) (b.map e.symm) + (quotientEnd C Z hZC) := by + have hadaptedR : IsStrictUpperTriangular + (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) r)) := + leftMultiplicationMatrix_isStrictUpperTriangular b level hadapted hr + have hmatrix := adaptedBasis_conditional_trace_assembler + C Z T hExact hZC hTC hparameter (b.map e.symm) + (strictTriangularSignedSum Xcorr Ycorr Γ) Θ Φ Ψ H + (strictTriangularSignedSum_isStrictUpperTriangular + Xcorr Ycorr Γ hXcorr hYcorr hΓ) hdecomposition + refine ⟨hadaptedR, leftMultiplicationMatrix_isNilpotent b hr, hmatrix.2, ?_⟩ + rw [hZaction, ← leftMultiplicationMatrix_decomposition b q r z hz] + +-- The adapted-basis strictness above is deliberately retained as a separate +-- output: it records the source's stronger triangular statement even though +-- nilpotence alone is consumed by equations (3.1)--(3.2). + + +end Proposition32Adapter + +end + +end Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianCoefficientField.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianCoefficientField.lean new file mode 100644 index 0000000000..cc23e46dab --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianCoefficientField.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.AlgebraicIndependent.Adjoin +import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis +import Mathlib.RingTheory.Artinian.Ring +import Mathlib.RingTheory.Etale.Field + +/-! +# Coefficient fields in equal-characteristic-zero Artinian local rings + +The Artinian-local trace argument needs a genuine coefficient field: a +section of the residue map by a field homomorphism. Mathlib does not package +the equal-characteristic coefficient-field theorem directly. This file +proves the required characteristic-zero case from its formal-smoothness API. + +The field-theoretic input is that every characteristic-zero field extension +is formally smooth. A transcendence basis factors the extension into a +rational-function extension and an algebraic separable extension. The first +is formally smooth because polynomial algebras and localizations are; the +second is formally etale because characteristic-zero fields are perfect. + +For an Artinian local algebra, the maximal ideal is nilpotent. Formal +smoothness of the residue field therefore lifts its identity map through the +residue quotient, producing the coefficient-field section. +-/ + +noncomputable section + +namespace Stafford38.Characteristic.ArtinianCoefficientField + +open Algebra +open scoped IntermediateField + +universe u + +/-- Every extension of a characteristic-zero field is formally smooth. + +Mathlib's `Algebra.IsSeparable` describes algebraic separability, so the +transcendental part is first isolated with a transcendence basis. -/ +theorem formallySmooth_fieldExtension_of_charZero + (F E : Type u) [Field F] [Field E] [Algebra F E] [CharZero F] : + Algebra.FormallySmooth F E := by + obtain ⟨ι, x, hx⟩ := + exists_isTranscendenceBasis' F E + let K := IntermediateField.adjoin F (Set.range x) + let P := MvPolynomial ι F + let L := FractionRing P + haveI : Algebra.FormallySmooth F P := inferInstance + haveI : Algebra.FormallySmooth P L := + Algebra.FormallySmooth.of_isLocalization (nonZeroDivisors P) + haveI : Algebra.FormallySmooth F L := + Algebra.FormallySmooth.comp F P L + haveI : Algebra.FormallySmooth F K := + Algebra.FormallySmooth.of_equiv hx.1.aevalEquivField + haveI : Algebra.IsAlgebraic K E := hx.isAlgebraic_field + haveI : CharZero K := + charZero_of_injective_algebraMap (algebraMap F K).injective + haveI : PerfectField K := PerfectField.ofCharZero + haveI : Algebra.IsSeparable K E := inferInstance + haveI : Algebra.FormallyEtale K E := + Algebra.FormallyEtale.of_isSeparable K E + exact Algebra.FormallySmooth.comp F K E + +section ArtinianLocal + +variable (F R : Type u) [Field F] [CharZero F] +variable [CommRing R] [Algebra F R] [IsLocalRing R] [IsArtinianRing R] + +local notation "𝔪" => IsLocalRing.maximalIdeal R +local notation "κ" => IsLocalRing.ResidueField R + +/-- The maximal ideal of a commutative Artinian local ring is nilpotent. -/ +lemma maximalIdeal_isNilpotent : IsNilpotent 𝔪 := by + rw [← IsLocalRing.jacobson_eq_maximalIdeal (⊥ : Ideal R)] + · exact IsArtinianRing.isNilpotent_jacobson_bot + · exact bot_ne_top + +/-- An equal-characteristic-zero Artinian local algebra contains a coefficient +field: the residue map has a section as an algebra homomorphism over the base +field. -/ +theorem exists_residue_algHom_section : + ∃ s : κ →ₐ[F] R, + (Ideal.Quotient.mkₐ F 𝔪).comp s = AlgHom.id F κ := by + letI : Algebra.FormallySmooth F κ := + formallySmooth_fieldExtension_of_charZero F κ + exact Algebra.FormallySmooth.exists_lift 𝔪 + (maximalIdeal_isNilpotent (R := R)) (AlgHom.id F κ) + +/-- Pointwise form of `exists_residue_algHom_section`. -/ +theorem exists_residue_section : + ∃ s : κ →ₐ[F] R, ∀ a : κ, IsLocalRing.residue R (s a) = a := by + obtain ⟨s, hs⟩ := exists_residue_algHom_section F R + refine ⟨s, fun a ↦ ?_⟩ + exact AlgHom.congr_fun hs a + + +end ArtinianLocal + +end Stafford38.Characteristic.ArtinianCoefficientField diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianEquation33TraceProducer.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianEquation33TraceProducer.lean new file mode 100644 index 0000000000..cd3a3ca3df --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianEquation33TraceProducer.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Matrix.Trace +import Mathlib.RingTheory.Ideal.Maps + +/-! +# Matrix trace reductions for equation (3.3) + +This file isolates the matrix implication actually used after Singh--Kumar, +Proposition 3.2, equation (3.3). The calculation has three coefficient +layers, which must not be conflated. + +Over the deformation ring, equation (3.3) produces a strict +upper-triangular remainder and two correction matrices. The corrections need +not have zero trace there: the source proves separately that each trace lies in +the parameter ideal. Reduction modulo the parameter kills those traces, and a +second map to the coefficient field preserves their vanishing. + +In particular, no same-size coefficient-field commutator decomposition is +assumed. This file does not construct the matrices from a deformation module, +instantiate the localized right-Rees ring, identify the reduced matrix with +the induced `z`-action, or prove the high-power Artinian reduction. +-/ + +namespace Stafford38.Characteristic.ArtinianEquation33TraceProducer + +open Matrix + +noncomputable section + +universe u + +variable {B Abar K : Type u} +variable [Ring B] [CommRing Abar] [Field K] +variable {n : ℕ} + +/-- A parameter reduction whose kernel is its principal two-sided ideal. -/ +structure ParameterIdealReduction + (B Abar : Type u) [Ring B] [CommRing Abar] where + parameter : B + modParameter : B →+* Abar + ker_modParameter : RingHom.ker modParameter = Ideal.span {parameter} + +/-- Strict upper triangularity over an arbitrary coefficient ring. -/ +def IsStrictUpperTriangularOver {S : Type u} [Zero S] + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) S) : Prop := + ∀ i j, j ≤ i → M i j = 0 + +/-- A correction trace has precisely the source-level property used after +equation (3.3): it lies in the parameter ideal before reduction. -/ +def CorrectionTraceInParameter + (S : ParameterIdealReduction B Abar) + (Q : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : Prop := + Matrix.trace Q ∈ Ideal.span {S.parameter} + +/-- Coefficientwise reduction of the three terms retained from equation +(3.3), first modulo the parameter and then to the coefficient field. The +correction matrices are not replaced by coefficient-field commutators. -/ +def reducedEquation33Matrix + (S : ParameterIdealReduction B Abar) + (residue : Abar →+* K) + (R Q₁ Q₂ : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + (R.map S.modParameter).map residue + + (Q₁.map S.modParameter).map residue + + (Q₂.map S.modParameter).map residue + +/-- A strict upper-triangular deformation-ring remainder stays strict upper +triangular in the Artinian quotient. -/ +theorem modParameter_isStrictUpperTriangular + (S : ParameterIdealReduction B Abar) + (R : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hR : IsStrictUpperTriangularOver R) : + IsStrictUpperTriangularOver (R.map S.modParameter) := by + intro i j hji + simp [Matrix.map_apply, hR i j hji] + +/-- A strict upper-triangular matrix over the Artinian quotient has zero +trace, before passing to the coefficient field. -/ +theorem modParameter_remainder_trace_eq_zero + (S : ParameterIdealReduction B Abar) + (R : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hR : IsStrictUpperTriangularOver R) : + Matrix.trace (R.map S.modParameter) = 0 := by + rw [Matrix.trace] + apply Finset.sum_eq_zero + intro i _hi + exact modParameter_isStrictUpperTriangular S R hR i i le_rfl + +/-- A correction can have nonzero trace before reduction. Membership of that +trace in the parameter ideal is exactly what makes its trace zero in the +Artinian quotient. -/ +theorem modParameter_correction_trace_eq_zero + (S : ParameterIdealReduction B Abar) + (Q : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hQ : CorrectionTraceInParameter S Q) : + Matrix.trace (Q.map S.modParameter) = 0 := by + have hker : Matrix.trace Q ∈ RingHom.ker S.modParameter := by + rw [S.ker_modParameter] + exact hQ + have hreduce : S.modParameter (Matrix.trace Q) = 0 := hker + simpa using + (AddMonoidHom.map_trace S.modParameter.toAddMonoidHom Q).symm.trans hreduce + +/-- Zero trace in the Artinian quotient remains zero after the separate +residue/coefficient-field projection. -/ +theorem residue_trace_eq_zero + (residue : Abar →+* K) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) Abar) + (hM : Matrix.trace M = 0) : + Matrix.trace (M.map residue) = 0 := by + calc + Matrix.trace (M.map residue) = residue (Matrix.trace M) := by + simpa using (AddMonoidHom.map_trace residue.toAddMonoidHom M).symm + _ = 0 := by rw [hM, map_zero] + +/-- The separate source reductions imply trace zero for the coefficient-field +matrix represented by equation (3.3). -/ +theorem reducedEquation33Matrix_trace_eq_zero + (S : ParameterIdealReduction B Abar) + (residue : Abar →+* K) + (R Q₁ Q₂ : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hR : IsStrictUpperTriangularOver R) + (hQ₁ : CorrectionTraceInParameter S Q₁) + (hQ₂ : CorrectionTraceInParameter S Q₂) : + Matrix.trace (reducedEquation33Matrix S residue R Q₁ Q₂) = 0 := by + rw [reducedEquation33Matrix, Matrix.trace_add, Matrix.trace_add, + residue_trace_eq_zero residue (R.map S.modParameter) + (modParameter_remainder_trace_eq_zero S R hR), + residue_trace_eq_zero residue (Q₁.map S.modParameter) + (modParameter_correction_trace_eq_zero S Q₁ hQ₁), + residue_trace_eq_zero residue (Q₂.map S.modParameter) + (modParameter_correction_trace_eq_zero S Q₂ hQ₂)] + simp + + +end + +end Stafford38.Characteristic.ArtinianEquation33TraceProducer diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianTriangularTrace.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianTriangularTrace.lean new file mode 100644 index 0000000000..5276eeb522 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ArtinianTriangularTrace.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Matrix.Charpoly.Coeff + +/-! +# The Artinian triangular trace calculation + +This file formalizes the terminal finite-dimensional trace core used in +Singh--Kumar, Proposition 3.2. +After choosing a coefficient field in the commutative Artinian special fibre +and a basis adapted to powers of its maximal ideal, the action of a lifted +maximal-ideal element is strictly triangular. The first-order commutator +calculation then represents the bracket-cofactor action as + +`R + (ΘA - AΘ) + (BΓ - ΓB)`, + +where `R` is strictly upper triangular. Its trace is zero. On the other +hand, the residue decomposition of that action is a scalar matrix plus a +nilpotent matrix. In positive dimension and characteristic zero the scalar +must therefore vanish. + +The faithful terminal theorem assumes only that the induced operator has trace +zero. This is exactly what the source proves from equation (3.3); it does not +identify the correction terms with commutators of same-size matrices over the +coefficient field. A stronger commutator-shaped corollary is retained as an +abstract convenience, but is not claimed to follow directly from the source. + +This file does not construct the coefficient field or adapted basis, derive +the trace-zero operator from a square-zero module, or connect it to the +localized right Rees module. +-/ + +namespace Stafford38.Characteristic.ArtinianTriangularTrace + +open Matrix + +noncomputable section + +universe u + +variable {K : Type u} [Field K] +variable {n : ℕ} + +/-- A square matrix is strictly upper triangular when every entry on or below +the diagonal is zero. -/ +def IsStrictUpperTriangular + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) K) : Prop := + ∀ i j, j ≤ i → M i j = 0 + +/-- A strictly upper triangular matrix has zero trace. -/ +theorem trace_eq_zero_of_isStrictUpperTriangular + {M : Matrix (Fin (n + 1)) (Fin (n + 1)) K} + (hM : IsStrictUpperTriangular M) : + Matrix.trace M = 0 := by + rw [Matrix.trace] + apply Finset.sum_eq_zero + intro i _hi + exact hM i i le_rfl + +/-- Written-order matrix commutator. -/ +def matrixCommutator + (X Y : Matrix (Fin (n + 1)) (Fin (n + 1)) K) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + X * Y - Y * X + +/-- Cyclicity of matrix trace kills a matrix commutator over the coefficient +field. -/ +theorem trace_matrixCommutator_eq_zero + (X Y : Matrix (Fin (n + 1)) (Fin (n + 1)) K) : + Matrix.trace (matrixCommutator X Y) = 0 := by + rw [matrixCommutator, Matrix.trace_sub, Matrix.trace_mul_comm, sub_self] + +/-- The matrix left after the maximal-ideal-adapted first-order calculation. +The order of both commutators is the order occurring in the published +calculation. -/ +def adaptedFirstOrderMatrix + (R Θ A B Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + R + matrixCommutator Θ A + matrixCommutator B Γ + +/-- The adapted first-order matrix has trace zero. No triangularity of +`A`, `B`, `Γ`, or `Θ` is needed after the calculation has isolated the +strictly triangular remainder `R`. -/ +theorem trace_adaptedFirstOrderMatrix_eq_zero + (R Θ A B Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hR : IsStrictUpperTriangular R) : + Matrix.trace (adaptedFirstOrderMatrix R Θ A B Γ) = 0 := by + simp only [adaptedFirstOrderMatrix, Matrix.trace_add, + trace_eq_zero_of_isStrictUpperTriangular hR, + trace_matrixCommutator_eq_zero, zero_add] + +/-- Faithful terminal trace calculation used by Proposition 3.2. + +The source-specific work upstream proves that the induced operator `T` has +trace zero. The coefficient-field decomposition gives `q I + U = T`, where +maximal-ideal multiplication makes `U` nilpotent. Positive dimension and +characteristic zero then force `q = 0`. +-/ +theorem scalar_eq_zero_of_trace_identity + [CharZero K] + (q : K) + (U T : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hU : IsNilpotent U) + (htraceT : Matrix.trace T = 0) + (hidentity : + q • (1 : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + U = T) : + q = 0 := by + have htraceU : Matrix.trace U = 0 := by + exact isNilpotent_iff_eq_zero.mp + (Matrix.isNilpotent_trace_of_isNilpotent hU) + have htrace := congrArg Matrix.trace hidentity + rw [Matrix.trace_add, Matrix.trace_smul, Matrix.trace_one, htraceU, + add_zero, htraceT, smul_eq_mul] at htrace + exact (mul_eq_zero.mp htrace).resolve_right + (Nat.cast_ne_zero.mpr (by simp)) + +/-- Stronger abstract corollary with an explicit commutator decomposition. + +This implication is correct, but Proposition 3.2 does not directly provide its +same-size coefficient-field matrix identity. The source-specific adapter +should instead establish the zero-trace hypothesis of +`scalar_eq_zero_of_trace_identity`. +-/ +theorem scalar_eq_zero_of_adapted_triangular_matrix_identity + [CharZero K] + (q : K) + (U R Θ A B Γ : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + (hU : IsNilpotent U) + (hR : IsStrictUpperTriangular R) + (hidentity : + q • (1 : Matrix (Fin (n + 1)) (Fin (n + 1)) K) + U = + adaptedFirstOrderMatrix R Θ A B Γ) : + q = 0 := + scalar_eq_zero_of_trace_identity q U + (adaptedFirstOrderMatrix R Θ A B Γ) hU + (trace_adaptedFirstOrderMatrix_eq_zero R Θ A B Γ hR) hidentity + + +end + +end Stafford38.Characteristic.ArtinianTriangularTrace diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedFinite.lean b/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedFinite.lean new file mode 100644 index 0000000000..1323437966 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedFinite.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedExactness + +/-! +# Finiteness of the actual order-associated graded module + +The actual associated graded quotient is cyclic over the commutative symbol +ring. This file records the resulting `Module.Finite` instance and feeds it +to the already checked minimal-prime localization theorem. No Noetherian, +trace, or involutivity conclusion is hidden in the construction. +-/ + +namespace Stafford38.Characteristic.AssociatedGradedFinite + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The cyclic presentation map from the symbol ring to the literal external +direct sum associated graded module. -/ +def generatorMap (I : RightIdeal (PresentedWeyl k n)) : + SymbolRing k n →ₗ[SymbolRing k n] OrderAssociatedGradedModule k I := + LinearMap.toSpanSingleton (SymbolRing k n) + (OrderAssociatedGradedModule k I) + (orderAssociatedGradedGenerator k I) + +/-- Cyclicity of the actual associated graded object is surjectivity of its +literal one-generator presentation map. -/ +theorem generatorMap_surjective (I : RightIdeal (PresentedWeyl k n)) : + Function.Surjective (generatorMap k I) := by + intro q + obtain ⟨P, hP⟩ := exists_smul_orderAssociatedGradedGenerator k I q + exact ⟨P, by simpa [generatorMap, LinearMap.toSpanSingleton_apply] using hP⟩ + +/-- The literal order-associated graded quotient is finite over the symbol +ring, with one generator. -/ +noncomputable instance orderAssociatedGradedModule_finite + (I : RightIdeal (PresentedWeyl k n)) : + Module.Finite (SymbolRing k n) (OrderAssociatedGradedModule k I) := + Module.Finite.of_surjective (generatorMap k I) (generatorMap_surjective k I) + +/-- Concrete minimal-prime localization package with no unproduced finiteness +hypothesis: exact two-jet specialization, nontrivial localized fibre, and +finite length all hold at a minimal prime over the actual annihilator. -/ +theorem exists_minimalPrimeLocalizedExactnessAndFiniteLength + [IsNoetherianRing (SymbolRing k n)] + (I : RightIdeal (PresentedWeyl k n)) + (P : Ideal (SymbolRing k n)) [P.IsPrime] + (hP : P ∈ + (Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I)).minimalPrimes) : + ∃ h : OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) + P.primeCompl), + LocalizedExactnessFor (filteredQuotientTwoJetTraceData k I) + P.primeCompl h ∧ + Nontrivial + (LocalizedModule P.primeCompl (OrderAssociatedGradedModule k I)) ∧ + IsFiniteLength (Localization P.primeCompl) + (LocalizedModule P.primeCompl + (OrderAssociatedGradedModule k I)) := + SquareZeroLocalizedExactness.exists_minimalPrimeLocalizedExactnessAndFiniteLength + (filteredQuotientTwoJetTraceData k I) P hP + + +end + +end Stafford38.Characteristic.AssociatedGradedFinite diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedModule.lean b/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedModule.lean new file mode 100644 index 0000000000..dc289564cb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/AssociatedGradedModule.lean @@ -0,0 +1,386 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSupport +import Mathlib.RingTheory.Ideal.Colon + +/-! +# The symbol-ring module on the actual associated graded quotient + +The filtered quotient construction already gives the actual degree pieces of +`A / I`, their external direct sum, and an exact global symbol map whose kernel +is `orderInitialIdeal`. This file uses that exact bridge to put the genuine +`SymbolRing`-module structure on a dedicated copy of the actual associated +graded object. + +The construction is not merely additive: the resulting module is linearly +equivalent over `SymbolRing` to its cyclic quotient by `orderInitialIdeal`, and +its annihilator is proved equal (not merely comparable) to that ideal. No +Rees algebra, radical involutivity, or Gabber theorem is asserted here. +-/ + +namespace Stafford38.CharacteristicAssociatedGradedModule + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicFilteredQuotientSupport +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylPBW + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (n := n) k) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- A dedicated type for the actual external direct sum of the order-filtered +quotient pieces. The new type keeps the symbol-ring action introduced below +from creating an instance on the underlying `DirectSum` globally. -/ +def OrderAssociatedGradedModule + (I : RightIdeal (PresentedWeyl k n)) := + QuotientOrderAssociatedGraded k I + +instance (I : RightIdeal (PresentedWeyl k n)) : AddCommGroup + (OrderAssociatedGradedModule k I) := + inferInstanceAs (AddCommGroup (QuotientOrderAssociatedGraded k I)) + +instance (I : RightIdeal (PresentedWeyl k n)) : Module k + (OrderAssociatedGradedModule k I) := + inferInstanceAs (Module k (QuotientOrderAssociatedGraded k I)) + +/-- The exact additive identification of the actual associated graded object +with the cyclic symbol quotient. -/ +def orderAssociatedGradedAddEquivCharacteristic + (I : RightIdeal (PresentedWeyl k n)) : + OrderAssociatedGradedModule k I ≃+ + OrderCharacteristicModule k I := + quotientOrderAssociatedGradedAddEquivCharacteristic k I + +/-- The change from the quotient by the restricted `k`-submodule to the +ideal quotient is also `k`-linear. -/ +def restrictScalarsQuotientLinearEquiv + (I : RightIdeal (PresentedWeyl k n)) : + (SymbolRing k n ⧸ (orderInitialIdeal k I).restrictScalars k) ≃ₗ[k] + OrderCharacteristicModule k I := + { restrictScalarsQuotientAddEquiv k I with + map_smul' := by + intro c q + refine Submodule.Quotient.induction_on _ q ?_ + intro P + rfl } + +@[simp] theorem restrictScalarsQuotientLinearEquiv_mk + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) : + restrictScalarsQuotientLinearEquiv k I + (Submodule.Quotient.mk P) = + Ideal.Quotient.mk (orderInitialIdeal k I) P := + rfl + +/-- Before adding the full symbol action, the global identification is the +existing `k`-linear equivalence. -/ +def orderAssociatedGradedLinearEquivCharacteristicOverBase + (I : RightIdeal (PresentedWeyl k n)) : + OrderAssociatedGradedModule k I ≃ₗ[k] + OrderCharacteristicModule k I := + quotientOrderAssociatedGradedEquivCharacteristic k I ≪≫ₗ + restrictScalarsQuotientLinearEquiv k I + +/-- The symbol-ring action transported through the exact global symbol map. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + Module (SymbolRing k n) (OrderAssociatedGradedModule k I) := + (orderAssociatedGradedAddEquivCharacteristic k I).module (SymbolRing k n) + +/-- The transported symbol action restricts to the original coefficient-field +action on the actual associated graded pieces. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + IsScalarTower k (SymbolRing k n) (OrderAssociatedGradedModule k I) := + LinearEquiv.isScalarTower (A := SymbolRing k n) + (orderAssociatedGradedLinearEquivCharacteristicOverBase k I) + +/-- The actual associated graded quotient is a genuine module over the symbol +ring, linearly equivalent over that ring to the cyclic quotient by the order +initial ideal. -/ +def orderAssociatedGradedLinearEquivCharacteristic + (I : RightIdeal (PresentedWeyl k n)) : + OrderAssociatedGradedModule k I ≃ₗ[SymbolRing k n] + OrderCharacteristicModule k I := + { orderAssociatedGradedAddEquivCharacteristic k I with + map_smul' := by + intro P q + change orderAssociatedGradedAddEquivCharacteristic k I + ((orderAssociatedGradedAddEquivCharacteristic k I).symm + (P • orderAssociatedGradedAddEquivCharacteristic k I q)) = + P • orderAssociatedGradedAddEquivCharacteristic k I q + exact (orderAssociatedGradedAddEquivCharacteristic k I).apply_symm_apply _ } + +/-- Insert one actual order-graded quotient piece into the global direct sum. -/ +def orderAssociatedGradedOf + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (q : QuotientOrderGradedPiece k I N) : + OrderAssociatedGradedModule k I := + DirectSum.of (fun N => QuotientOrderGradedPiece k I N) N q + +private theorem orderCharacteristicModuleEquivRelationGraded_mk + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) : + orderCharacteristicModuleEquivRelationGraded k I + (Submodule.Quotient.mk P) = + symbolToOrderRelationGraded k I P := by + rfl + +/-- The global characteristic equivalence sends the class of a filtered +representative in degree `N` to the class of its degree-`N` principal symbol. +This is the commuting-square statement that connects the transported module +to the actual filtered quotient pieces. -/ +theorem orderAssociatedGradedLinearEquivCharacteristic_of_mk + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (z : orderPiece k n N) : + orderAssociatedGradedLinearEquivCharacteristic k I + (orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z)) = + Ideal.Quotient.mk (orderInitialIdeal k I) + (presentedPrincipalComponent k orderWeight N z) := by + change restrictScalarsQuotientLinearEquiv k I + (quotientOrderAssociatedGradedEquivCharacteristic k I + (orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z))) = _ + have hsource : + quotientOrderAssociatedGradedEquivCharacteristic k I + (orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z)) = + Submodule.Quotient.mk + (presentedPrincipalComponent k orderWeight N z) := by + have htrans := LinearEquiv.trans_apply + (e₁₂ := quotientOrderAssociatedGradedEquivSymbols k I) + (e₂₃ := (orderCharacteristicModuleEquivRelationGraded k I).symm) + (orderAssociatedGradedOf k I N (orderPieceToQuotientGraded k I N z)) + rw [quotientOrderAssociatedGradedEquivCharacteristic, htrans] + apply (orderCharacteristicModuleEquivRelationGraded k I).injective + rw [LinearEquiv.apply_symm_apply] + apply DFinsupp.ext + intro M + rw [orderCharacteristicModuleEquivRelationGraded_mk] + rw [symbolToOrderRelationGraded_apply] + change + ((DFinsupp.mapRange.linearEquiv fun L => + quotientOrderGradedPieceEquivSymbols k I L) + (DirectSum.of (fun L => QuotientOrderGradedPiece k I L) N + (orderPieceToQuotientGraded k I N z))) M = + Submodule.Quotient.mk + ((DirectSum.decompose + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n)) + (principalComponentOnPiece k (@orderWeight n) N z : + SymbolRing k n)) M) + rw [DFinsupp.mapRange.linearEquiv_apply, DirectSum.decompose_coe] + change quotientOrderGradedPieceEquivSymbols k I M + ((DirectSum.of (fun L => QuotientOrderGradedPiece k I L) N + (orderPieceToQuotientGraded k I N z)) M) = + Submodule.Quotient.mk + ((DirectSum.of (fun L => + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) L) N + (principalComponentOnPiece k (@orderWeight n) N z)) M) + by_cases hMN : N = M + · subst M + rw [DirectSum.of_eq_same, DirectSum.of_eq_same, + quotientOrderGradedPieceEquivSymbols_mk] + · rw [DirectSum.of_eq_of_ne _ _ _ (Ne.symm hMN), + DirectSum.of_eq_of_ne _ _ _ (Ne.symm hMN)] + rw [(quotientOrderGradedPieceEquivSymbols k I M).map_zero] + exact (Submodule.Quotient.mk_zero _).symm + calc + _ = restrictScalarsQuotientLinearEquiv k I + (Submodule.Quotient.mk + (presentedPrincipalComponent k orderWeight N z)) := + congrArg (restrictScalarsQuotientLinearEquiv k I) hsource + _ = _ := restrictScalarsQuotientLinearEquiv_mk k I _ + +private theorem symbol_smul_characteristicModule_mk + (I : RightIdeal (PresentedWeyl k n)) (P Q : SymbolRing k n) : + P • Ideal.Quotient.mk (orderInitialIdeal k I) Q = + Ideal.Quotient.mk (orderInitialIdeal k I) (P * Q) := by + change P • (Submodule.Quotient.mk Q : + SymbolRing k n ⧸ + (orderInitialIdeal k I : Submodule (SymbolRing k n) (SymbolRing k n))) = + Submodule.Quotient.mk (P * Q) + rw [← Submodule.Quotient.mk_smul + (orderInitialIdeal k I : Submodule (SymbolRing k n) (SymbolRing k n)) + P Q] + rfl + +/-- Multiplication by a homogeneous symbol on the transported global module +is exactly the canonical degree-shifting action on the actual quotient graded +piece. The right side is the action constructed from right multiplication in +the filtered Weyl quotient, not a second transported definition. -/ +theorem smul_orderAssociatedGradedOf_eq_of_homogeneousAction + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) + (q : QuotientOrderGradedPiece k I N) : + (P : SymbolRing k n) • orderAssociatedGradedOf k I N q = + orderAssociatedGradedOf k I (N + M) + (quotientOrderHomogeneousAction k I P q) := by + obtain ⟨z, rfl⟩ := orderPieceToQuotientGraded_surjective k I N q + obtain ⟨y, hy⟩ := + principalComponentOnPiece_surjective k (@orderWeight n) P + subst P + apply (orderAssociatedGradedLinearEquivCharacteristic k I).injective + rw [map_smul, orderAssociatedGradedLinearEquivCharacteristic_of_mk, + quotientOrderHomogeneousAction_mk_mul, + orderAssociatedGradedLinearEquivCharacteristic_of_mk, + symbol_smul_characteristicModule_mk] + apply congrArg (Ideal.Quotient.mk (orderInitialIdeal k I)) + rw [presentedPrincipalComponent_mul_order k z.property y.property] + exact mul_comm _ _ + +/-- Representative form of homogeneous compatibility: the symbol of `y` +acting on the degree-`N` class of `z` is the degree-`N+M` class represented by +the written-order Weyl product `z * y`. -/ +theorem smul_orderAssociatedGradedOf_mk_eq_of_mul + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} + (z : orderPiece k n N) (y : orderPiece k n M) : + (principalComponentOnPiece k (@orderWeight n) M y : SymbolRing k n) • + orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z) = + orderAssociatedGradedOf k I (N + M) + (orderPieceToQuotientGraded k I (N + M) + ⟨(z : PresentedWeyl k n) * y, + mul_mem_orderPiece k z.property y.property⟩) := by + rw [smul_orderAssociatedGradedOf_eq_of_homogeneousAction, + quotientOrderHomogeneousAction_mk_mul] + +/-- The unit operator belongs to the degree-zero order piece. -/ +def orderPieceOne : orderPiece k n 0 := + ⟨1, by + rw [orderPiece, mem_presentedWeightPiece] + intro m hm + rw [presentedNormalFormLinearEquiv_one] at hm + have hm0 : m = 0 := by + symm + simpa [MvPolynomial.coeff_one] using hm + subst m + simp [monomialWeight]⟩ + +@[simp] theorem presentedPrincipalComponent_orderPieceOne : + presentedPrincipalComponent k (@orderWeight n) 0 + (orderPieceOne (n := n) k) = 1 := by + change presentedPrincipalComponent k (@orderWeight n) 0 + (1 : PresentedWeyl k n) = 1 + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, presentedNormalFormLinearEquiv_one] + conv_lhs => rw [show (1 : SymbolRing k n) = + MvPolynomial.monomial 0 1 by simp] + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight] + +/-- The literal degree-zero class of the unit operator in the actual filtered +quotient. -/ +def orderAssociatedGradedOneClass + (I : RightIdeal (PresentedWeyl k n)) : + OrderAssociatedGradedModule k I := + orderAssociatedGradedOf k I 0 + (orderPieceToQuotientGraded k I 0 (orderPieceOne (n := n) k)) + +/-- The distinguished cyclic vector corresponding to the class of `1` in the +symbol quotient. -/ +def orderAssociatedGradedGenerator + (I : RightIdeal (PresentedWeyl k n)) : + OrderAssociatedGradedModule k I := + (orderAssociatedGradedLinearEquivCharacteristic k I).symm 1 + +@[simp] theorem orderAssociatedGradedLinearEquivCharacteristic_generator + (I : RightIdeal (PresentedWeyl k n)) : + orderAssociatedGradedLinearEquivCharacteristic k I + (orderAssociatedGradedGenerator k I) = 1 := + (orderAssociatedGradedLinearEquivCharacteristic k I).apply_symm_apply 1 + +/-- The transported cyclic generator is not an abstract chosen preimage: it +is exactly the degree-zero class of the unit filtered representative. -/ +theorem orderAssociatedGradedGenerator_eq_oneClass + (I : RightIdeal (PresentedWeyl k n)) : + orderAssociatedGradedGenerator k I = + orderAssociatedGradedOneClass k I := by + apply (orderAssociatedGradedLinearEquivCharacteristic k I).injective + rw [orderAssociatedGradedLinearEquivCharacteristic_generator, + orderAssociatedGradedOneClass, + orderAssociatedGradedLinearEquivCharacteristic_of_mk, + presentedPrincipalComponent_orderPieceOne] + exact (Ideal.Quotient.mk (orderInitialIdeal k I)).map_one + +private theorem symbol_smul_one_characteristicModule + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) : + P • (1 : OrderCharacteristicModule k I) = + Ideal.Quotient.mk (orderInitialIdeal k I) P := by + rw [← (Ideal.Quotient.mk (orderInitialIdeal k I)).map_one] + change P • (Submodule.Quotient.mk (1 : SymbolRing k n) : + SymbolRing k n ⧸ + (orderInitialIdeal k I : Submodule (SymbolRing k n) (SymbolRing k n))) = + Submodule.Quotient.mk P + rw [← Submodule.Quotient.mk_smul + (orderInitialIdeal k I : Submodule (SymbolRing k n) (SymbolRing k n)) + P (1 : SymbolRing k n)] + simp + +/-- Every element of the actual associated graded quotient is a symbol +multiple of the distinguished generator. -/ +theorem exists_smul_orderAssociatedGradedGenerator + (I : RightIdeal (PresentedWeyl k n)) + (q : OrderAssociatedGradedModule k I) : + ∃ P : SymbolRing k n, P • orderAssociatedGradedGenerator k I = q := by + obtain ⟨P, hP⟩ := Ideal.Quotient.mk_surjective + (orderAssociatedGradedLinearEquivCharacteristic k I q) + refine ⟨P, ?_⟩ + apply (orderAssociatedGradedLinearEquivCharacteristic k I).injective + rw [map_smul, orderAssociatedGradedLinearEquivCharacteristic_generator] + rw [symbol_smul_one_characteristicModule] + exact hP + +/-- A symbol kills the cyclic generator exactly when it belongs to the order +initial ideal. This is the elementwise form of the exact annihilator theorem. -/ +theorem smul_orderAssociatedGradedGenerator_eq_zero_iff + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) : + P • orderAssociatedGradedGenerator k I = 0 ↔ + P ∈ orderInitialIdeal k I := by + rw [← Ideal.Quotient.eq_zero_iff_mem] + constructor + · intro h + have h' : P • (1 : OrderCharacteristicModule k I) = 0 := by + simpa only [map_smul, + orderAssociatedGradedLinearEquivCharacteristic_generator, map_zero] + using congrArg (orderAssociatedGradedLinearEquivCharacteristic k I) h + rw [symbol_smul_one_characteristicModule] at h' + exact h' + · intro h + apply (orderAssociatedGradedLinearEquivCharacteristic k I).injective + rw [map_smul, orderAssociatedGradedLinearEquivCharacteristic_generator, + map_zero] + rw [symbol_smul_one_characteristicModule] + exact h + +/-- The annihilator of the actual associated graded quotient is exactly the +order initial ideal. -/ +theorem annihilator_orderAssociatedGradedModule + (I : RightIdeal (PresentedWeyl k n)) : + Module.annihilator (SymbolRing k n) (OrderAssociatedGradedModule k I) = + orderInitialIdeal k I := by + rw [(orderAssociatedGradedLinearEquivCharacteristic k I).annihilator_eq] + exact Ideal.annihilator_quotient + + +end + +end Stafford38.CharacteristicAssociatedGradedModule diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/BGab001CoefficientFieldTrace.lean b/LeanPool/Stafford38/Stafford38/Characteristic/BGab001CoefficientFieldTrace.lean new file mode 100644 index 0000000000..e429ddc617 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/BGab001CoefficientFieldTrace.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SourceActionCommutatorExpansion +import Mathlib.RingTheory.Finiteness.NilpotentKer + +/-! +# Actual traces using coefficient-field corrections + +The first-order source equations can be chosen with correction coefficients +in the coefficient field. Their commutators then have their actual matrix +traces. The remaining source matrix has arbitrary special-fibre coefficients, +but sends each basis vector to a strictly deeper maximal-ideal layer. This +is sufficient to kill its diagonal without replacing coefficients by residues. +-/ + +namespace Stafford38.Characteristic.BGab001CoefficientFieldTrace + +open Matrix +open Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +open Stafford38.Characteristic.ConcreteEquation33SourceMatrices +open Stafford38.Characteristic.ConcreteInducedZAction +open Stafford38.Characteristic.SourceActionCommutatorExpansion + +noncomputable section + +universe u +variable {K R V : Type u} [Field K] [CommRing R] [Algebra K R] +variable [IsLocalRing R] [AddCommGroup V] [Module K V] [Module R V] +variable [IsScalarTower K R V] {n : ℕ} +local notation "ι" => Fin (n + 1) + +/-- An arbitrary ring coefficient cannot bring a vector from a deeper adic +layer back to the diagonal of an adapted basis. -/ +theorem repr_smul_eq_zero_of_level_lt + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (a : R) (i j : ι) (hij : level i < level j) : + b.repr (a • b j) i = 0 := by + have hj : b j ∈ (IsLocalRing.maximalIdeal R) ^ level j • + (⊤ : Submodule R V) := by + have hs : b j ∈ Submodule.span K (b '' {l | level j ≤ level l}) := + (b.self_mem_span_image).mpr (show level j ≤ level j from le_rfl) + rw [← hb.power_span (level j)] at hs + exact hs + have ha := ((IsLocalRing.maximalIdeal R) ^ level j • + (⊤ : Submodule R V)).smul_mem a hj + have hs : a • b j ∈ Submodule.span K (b '' {l | level j ≤ level l}) := by + rw [← hb.power_span (level j)] + exact ha + by_contra hne + have hi := b.repr_support_subset_of_mem_span _ hs + (Finsupp.mem_support_iff.mpr hne) + exact (not_le_of_gt hij) hi + +/-- The diagonal of a whole source row vanishes when every nonzero entry +points to a strictly deeper layer. No term is reduced to the residue field. -/ +theorem repr_deeper_source_row_diagonal_eq_zero + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (M : Matrix ι ι R) + (hM : ∀ i j, level j ≤ level i → M i j = 0) (i : ι) : + b.repr (∑ j, M i j • b j) i = 0 := by + rw [map_sum, Finsupp.finsetSum_apply] + apply Finset.sum_eq_zero + intro j _ + by_cases hij : level j ≤ level i + · simp [hM i j hij] + · exact repr_smul_eq_zero_of_level_lt b level hb _ i j (lt_of_not_ge hij) + +/-- Actual action trace from a deeper-layer remainder and a coefficient-field +correction. This consumes action on basis vectors, not a residue matrix. -/ +theorem actual_trace_eq_correction_trace + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (T : Module.End K V) (M : Matrix ι ι R) (Q : Matrix ι ι K) + (hM : ∀ i j, level j ≤ level i → M i j = 0) + (hT : ∀ i, T (b i) = (∑ j, M i j • b j) + ∑ j, Q i j • b j) : + Matrix.trace (LinearMap.toMatrix b b T) = Matrix.trace Q := by + unfold Matrix.trace + apply Finset.sum_congr rfl + intro i _ + change LinearMap.toMatrix b b T i i = Q i i + rw [LinearMap.toMatrix_apply, hT i, map_add, Finsupp.add_apply, + repr_deeper_source_row_diagonal_eq_zero b level hb M hM i, zero_add] + simp [Finsupp.single_apply] + +/-- Both correction commutators have trace zero over the coefficient field. -/ +theorem actual_trace_eq_zero_of_coefficientField_corrections + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (T : Module.End K V) (M : Matrix ι ι R) + (A B Gamma Theta : Matrix ι ι K) + (hM : ∀ i j, level j ≤ level i → M i j = 0) + (hT : ∀ i, T (b i) = (∑ j, M i j • b j) + + ∑ j, (B * Gamma - Gamma * B + (Theta * A - A * Theta)) i j • b j) : + Matrix.trace (LinearMap.toMatrix b b T) = 0 := by + rw [actual_trace_eq_correction_trace b level hb T M _ hM hT, + Matrix.trace_add, Matrix.trace_sub, Matrix.trace_sub, + Matrix.trace_mul_comm B Gamma, Matrix.trace_mul_comm Theta A] + ring + +/-- The source-row matrix of a maximal-ideal action points strictly deeper +in the adapted filtration, independently of the ordering within a layer. -/ +theorem source_coefficients_deeper + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (a : R) (ha : a ∈ IsLocalRing.maximalIdeal R) : + ∀ i j, level j ≤ level i → b.repr (a • b i) j = 0 := by + intro i j hij + have hi : b i ∈ (IsLocalRing.maximalIdeal R) ^ level i • + (⊤ : Submodule R V) := by + have hs : b i ∈ Submodule.span K (b '' {l | level i ≤ level l}) := + (b.self_mem_span_image).mpr (show level i ≤ level i from le_rfl) + rw [← hb.power_span (level i)] at hs + exact hs + have hs : a • b i ∈ Submodule.span K (b '' {l | level i + 1 ≤ level l}) := by + rw [← hb.power_span (level i + 1)] + exact maximalIdeal_smul_mem_succ_power ha hi + by_contra hne + have hj := b.repr_support_subset_of_mem_span _ hs + (Finsupp.mem_support_iff.mpr hne) + change level i + 1 ≤ level j at hj + omega + +section SourceRing +variable {B W : Type u} [Ring B] [AddCommGroup W] [Module B W] + +private theorem deeper_mul + (level : ι → ℕ) (M N : Matrix ι ι B) + (hM : ∀ i j, level j ≤ level i → M i j = 0) + (hN : ∀ i j, level j ≤ level i → N i j = 0) : + ∀ i j, level j ≤ level i → (M * N) i j = 0 := by + intro i j hij + rw [Matrix.mul_apply] + apply Finset.sum_eq_zero + intro l _ + by_cases hl : level l ≤ level i + · rw [hM i l hl, zero_mul] + · rw [hN l j (hij.trans (le_of_lt (lt_of_not_ge hl))), mul_zero] + +/-- Gabber's local trace step from the actual square-zero module. Both +first-order correction matrices are produced over the coefficient field; +all parameter cofactors are produced with their deeper-layer support. -/ +theorem actual_commutator_cofactor_trace_eq_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := R)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hact : ∀ a w, rho (a • w) = S.modParameter a • rho w) + (hker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hexact : AddMonoidHom.ker (parameterAct (W := W) S.parameter) = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hc2 : S.parameter * S.parameter = 0) + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (x y z : B) (hx : S.modParameter x ∈ IsLocalRing.maximalIdeal R) + (hy : S.modParameter y ∈ IsLocalRing.maximalIdeal R) + (hxy : x * y - y * x = S.parameter * z) : + Matrix.trace (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) (S.modParameter z))) = 0 := by + classical + let Ax := leftMultiplicationEnd (K := K) (V := V) (S.modParameter x) + let By := leftMultiplicationEnd (K := K) (V := V) (S.modParameter y) + let A0 := (LinearMap.toMatrix b b Ax)ᵀ + let B0 := (LinearMap.toMatrix b b By)ᵀ + let A := liftedSourceActionMatrix S b Ax + let Bm := liftedSourceActionMatrix S b By + have hAmap : A.map S.modParameter = A0.map (algebraMap K R) := by + rw [liftedSourceActionMatrix_map, sourceActionCoefficients_eq_transpose_toMatrix_map] + have hBmap : Bm.map S.modParameter = B0.map (algebraMap K R) := by + rw [liftedSourceActionMatrix_map, sourceActionCoefficients_eq_transpose_toMatrix_map] + obtain ⟨Gamma, GammaK, hGamma, heqx⟩ := + exists_firstOrderSourceActionMatrix_over_coefficientField S rho hrho hact hker hc2 b x + obtain ⟨Theta, ThetaK, hTheta, heqy⟩ := + exists_firstOrderSourceActionMatrix_over_coefficientField S rho hrho hact hker hc2 b y + have hAz : ∀ i j, level j ≤ level i → A i j = 0 := by + intro i j hij + simp [A, liftedSourceActionMatrix, liftMatrix, sourceActionCoefficients, Ax, + source_coefficients_deeper b level hb _ hx i j hij] + have hBz : ∀ i j, level j ≤ level i → Bm i j = 0 := by + intro i j hij + simp [Bm, liftedSourceActionMatrix, liftMatrix, sourceActionCoefficients, By, + source_coefficients_deeper b level hb _ hy i j hij] + have hcomm : Bm.map S.modParameter * A.map S.modParameter = + A.map S.modParameter * Bm.map S.modParameter := by + rw [hAmap, hBmap, ← Matrix.map_mul, ← Matrix.map_mul] + congr 1 + dsimp [A0, B0] + rw [← Matrix.transpose_mul, ← Matrix.transpose_mul, + ← LinearMap.toMatrix_mul, ← LinearMap.toMatrix_mul] + congr 2 + ext v + exact smul_comm _ _ v + let X := factorMatrix S (scalarMatrixCommutator x Bm) + let Y := factorMatrix S (scalarMatrixCommutator y A) + let Omega := factorMatrix S (sourceMatrixCommutator Bm A) + have hXz : ∀ i j, level j ≤ level i → X i j = 0 := by + intro i j hij + simp [X, factorMatrix, scalarMatrixCommutator, hBz i j hij] + have hYz : ∀ i j, level j ≤ level i → Y i j = 0 := by + intro i j hij + simp [Y, factorMatrix, scalarMatrixCommutator, hAz i j hij] + have hOz : ∀ i j, level j ≤ level i → Omega i j = 0 := by + intro i j hij + simp [Omega, factorMatrix, sourceMatrixCommutator, + deeper_mul level Bm A hBz hAz i j hij, deeper_mul level A Bm hAz hBz i j hij] + let Rem := (X - Y + Omega).map S.modParameter + have hRem : ∀ i j, level j ≤ level i → Rem i j = 0 := by + intro i j hij + simp [Rem, Matrix.map_apply, hXz i j hij, hYz i j hij, hOz i j hij] + have hfc : S.modParameter S.parameter = 0 := by + apply (S.kernel_left _).mpr + exact ⟨1, mul_one _⟩ + have heq (i : ι) := rho_commutator_on_source_equations + S.parameter x y z S.modParameter rho S.parameter_comm hc2 hfc hxy hact hexact + A Bm Gamma Theta X Y Omega (liftedBasisVector rho hrho b) heqx heqy + (parameter_mul_factorMatrix S _ (scalarMatrixCommutator_map_eq_zero S x Bm)) + (parameter_mul_factorMatrix S _ (scalarMatrixCommutator_map_eq_zero S y A)) + (parameter_mul_factorMatrix S _ (sourceMatrixCommutator_map_eq_zero S Bm A hcomm)) i + let Q := B0 * GammaK - GammaK * B0 + (ThetaK * A0 - A0 * ThetaK) + have hmap : (sourceExpansionMatrix X Y Omega A Bm Gamma Theta).map S.modParameter = + Rem + Q.map (algebraMap K R) := by + have hAe i j := congrArg (fun M : Matrix ι ι R ↦ M i j) hAmap + have hBe i j := congrArg (fun M : Matrix ι ι R ↦ M i j) hBmap + have hGe i j := congrArg (fun M : Matrix ι ι R ↦ M i j) hGamma + have hTe i j := congrArg (fun M : Matrix ι ι R ↦ M i j) hTheta + simp only [Matrix.map_apply] at hAe hBe hGe hTe + ext i j + simp only [sourceExpansionMatrix, Rem, Q, Matrix.map_apply, Matrix.add_apply, + Matrix.sub_apply, Matrix.mul_apply, map_add, map_sub, map_sum, map_mul, + hAe, hBe, hGe, hTe] + abel + apply actual_trace_eq_zero_of_coefficientField_corrections b level hb _ Rem + A0 B0 GammaK ThetaK hRem + intro i + have heqi := heq i + simp only [rho_liftedBasisVector] at heqi + exact heqi.trans (by + change (∑ j, ((sourceExpansionMatrix X Y Omega A Bm Gamma Theta).map + S.modParameter) i j • b j) = _ + rw [hmap] + simp only [Matrix.add_apply, Matrix.map_apply, add_smul, Finset.sum_add_distrib, + IsScalarTower.algebraMap_smul] + simp only [Q, Matrix.add_apply, add_smul, Finset.sum_add_distrib]) + +/-- The local membership conclusion after choosing a coefficient field and +an adapted basis. The residue scalar is forced to zero by the actual trace. -/ +theorem commutator_cofactor_mem_maximalIdeal + [CharZero K] [IsArtinianRing R] + (S : LeftPrincipalParameterReduction (B := B) (Abar := R)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hact : ∀ a w, rho (a • w) = S.modParameter a • rho w) + (hker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hexact : AddMonoidHom.ker (parameterAct (W := W) S.parameter) = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hc2 : S.parameter * S.parameter = 0) + (b : Module.Basis ι K V) (level : ι → ℕ) + (hb : IsMaximalIdealFiltrationAdapted (IsLocalRing.maximalIdeal R) b level) + (hcoeff : Function.Surjective + ((IsLocalRing.residue R).comp (algebraMap K R))) + (x y z : B) (hx : S.modParameter x ∈ IsLocalRing.maximalIdeal R) + (hy : S.modParameter y ∈ IsLocalRing.maximalIdeal R) + (hxy : x * y - y * x = S.parameter * z) : + S.modParameter z ∈ IsLocalRing.maximalIdeal R := by + obtain ⟨q, hq⟩ := hcoeff (IsLocalRing.residue R (S.modParameter z)) + let r := S.modParameter z - algebraMap K R q + have hr : r ∈ IsLocalRing.maximalIdeal R := by + rw [← IsLocalRing.residue_eq_zero_iff] + change IsLocalRing.residue R (S.modParameter z - algebraMap K R q) = 0 + rw [map_sub, show IsLocalRing.residue R (algebraMap K R q) = + IsLocalRing.residue R (S.modParameter z) from hq, sub_self] + have hz : S.modParameter z = algebraMap K R q + r := by dsimp [r]; ring + have htrace := actual_commutator_cofactor_trace_eq_zero + S rho hrho hact hker hexact hc2 b level hb x y z hx hy hxy + have hq0 := Stafford38.Characteristic.ArtinianTriangularTrace.scalar_eq_zero_of_trace_identity + q _ _ (leftMultiplicationMatrix_isNilpotent b hr) htrace + (leftMultiplicationMatrix_decomposition b q r (S.modParameter z) hz).symm + simpa [r, hq0] using hr + +/-- An Artinian local algebra is finite over a coefficient field. -/ +theorem finite_over_coefficientField [IsArtinianRing R] + (hcoeff : Function.Surjective + ((IsLocalRing.residue R).comp (algebraMap K R))) : Module.Finite K R := by + let m := IsLocalRing.maximalIdeal R + letI : Module.Finite K (R ⧸ m) := + Module.Finite.of_surjective (Algebra.linearMap K (R ⧸ m)) hcoeff + apply Module.finite_of_surjective_of_ker_le_nilradical + (Ideal.Quotient.mkₐ K m) Ideal.Quotient.mk_surjective + · have hker : RingHom.ker (Ideal.Quotient.mkₐ K m) = m := by + ext z + exact Ideal.Quotient.eq_zero_iff_mem + rw [hker] + exact (Ideal.FG.isNilpotent_iff_le_nilradical + (IsNoetherian.noetherian m)).mp + (Stafford38.Characteristic.ArtinianCoefficientField.maximalIdeal_isNilpotent (R := R)) + · exact IsNoetherian.noetherian _ + +/-- Local Gabber membership with the finite-dimensional basis constructed +from the finite special-fibre module. No action matrix or trace is supplied. -/ +theorem artinian_local_commutator_cofactor_mem_maximalIdeal + [CharZero K] [IsArtinianRing R] [Module.Finite R V] [Nontrivial V] + (S : LeftPrincipalParameterReduction (B := B) (Abar := R)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hact : ∀ a w, rho (a • w) = S.modParameter a • rho w) + (hker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hexact : AddMonoidHom.ker (parameterAct (W := W) S.parameter) = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hc2 : S.parameter * S.parameter = 0) + (hcoeff : Function.Surjective + ((IsLocalRing.residue R).comp (algebraMap K R))) + (x y z : B) (hx : S.modParameter x ∈ IsLocalRing.maximalIdeal R) + (hy : S.modParameter y ∈ IsLocalRing.maximalIdeal R) + (hxy : x * y - y * x = S.parameter * z) : + S.modParameter z ∈ IsLocalRing.maximalIdeal R := by + letI : Module.Finite K R := finite_over_coefficientField hcoeff + letI : Module.Finite K V := Module.Finite.trans R V + obtain ⟨n, hn⟩ := Nat.exists_eq_succ_of_ne_zero + (ne_of_gt (Module.finrank_pos (R := K) (M := V))) + obtain ⟨b, level, hb⟩ := + Stafford38.Characteristic.ArtinianAdaptedBasisExistence.exists_maximalIdealFiltrationAdaptedBasis + (K := K) (R := R) (V := V) hn + exact commutator_cofactor_mem_maximalIdeal S rho hrho hact hker hexact hc2 + b level hb hcoeff x y z hx hy hxy + +end SourceRing + +section CoefficientFieldProduction + +variable {B W : Type u} +variable [Ring B] [AddCommGroup W] [Module B W] + +omit [Algebra K R] [Module K V] [IsScalarTower K R V] in +/-- Proposition 3.2 for a nonzero finite special fibre: the coefficient +field, finite basis, source corrections, and actual trace are all produced. -/ +theorem artinian_local_cofactor_mem_maximalIdeal + (F : Type u) [Field F] [CharZero F] [Algebra F R] + [IsArtinianRing R] [Module.Finite R V] [Nontrivial V] + (S : LeftPrincipalParameterReduction (B := B) (Abar := R)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hact : ∀ a w, rho (a • w) = S.modParameter a • rho w) + (hker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hexact : AddMonoidHom.ker (parameterAct (W := W) S.parameter) = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hc2 : S.parameter * S.parameter = 0) + (x y z : B) (hx : S.modParameter x ∈ IsLocalRing.maximalIdeal R) + (hy : S.modParameter y ∈ IsLocalRing.maximalIdeal R) + (hxy : x * y - y * x = S.parameter * z) : + S.modParameter z ∈ IsLocalRing.maximalIdeal R := by + let κ := IsLocalRing.ResidueField R + obtain ⟨s, hs⟩ := Stafford38.Characteristic.ArtinianCoefficientField.exists_residue_section F R + letI : CharZero κ := charZero_of_injective_algebraMap (algebraMap F κ).injective + letI : Algebra κ R := s.toRingHom.toAlgebra + letI : Module κ V := Module.compHom V (algebraMap κ R) + letI : IsScalarTower κ R V := IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + have hcoeff : Function.Surjective + ((IsLocalRing.residue R).comp (algebraMap κ R)) := fun a ↦ ⟨a, hs a⟩ + exact artinian_local_commutator_cofactor_mem_maximalIdeal + S rho hrho hact hker hexact hc2 hcoeff x y z hx hy hxy + +end CoefficientFieldProduction + + +end +end Stafford38.Characteristic.BGab001CoefficientFieldTrace diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizationModuleComparison.lean b/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizationModuleComparison.lean new file mode 100644 index 0000000000..a2e2c2c42c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizationModuleComparison.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizationModuleComparison + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.BaseLocalizationModuleComparison + +export AlgebraicAnalysis.BaseLocalizationModuleComparison (coefficientDenominator localizedModule_isLocalizedOverBase localizedModule_isLocalizedOverCoefficient localizedModuleComparison localizedModuleComparison_mkLinearMap localizedModuleComparison_mk localizedModuleComparison_natural) + +end Stafford38.Characteristic.BaseLocalizationModuleComparison diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizedKoszulPositivity.lean b/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizedKoszulPositivity.lean new file mode 100644 index 0000000000..98da905084 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/BaseLocalizedKoszulPositivity.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizationModuleComparison +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedMinimalSupportAvoidance +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulMinimalSupportPositivity + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.BaseLocalizedKoszulPositivity + +export AlgebraicAnalysis.BaseLocalizedKoszulPositivity (localized_length_cokernel_gt_kernel) + +end Stafford38.Characteristic.BaseLocalizedKoszulPositivity diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/BaseRelativePoisson.lean b/LeanPool/Stafford38/Stafford38/Characteristic/BaseRelativePoisson.lean new file mode 100644 index 0000000000..210aeab4f7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/BaseRelativePoisson.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CoisotropicTranslation + +/-! +# Base-relative Poisson closure + +The vertical-translation argument needs only brackets whose left entry comes +from the base-coordinate ring. This file isolates that exact hypothesis and +shows that it suffices for the existing Hamiltonian-iteration argument. + +No assertion is made here that a radical initial ideal, or the reduced +characteristic ideal of a Weyl module, satisfies this condition. Supplying +that fact is the remaining Gabber input. +-/ + +namespace Stafford38.Characteristic.BaseRelativePoisson + +open Stafford38.Characteristic +open Stafford38.Geometry.CoisotropicTranslation + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- +The exact base-relative fragment of Poisson involutivity: +`{J ∩ k[x], J} ⊆ J`, expressed using the canonical base embedding. +-/ +def IsBaseRelativePoisson (J : Ideal (SymbolRing k n)) : Prop := + ∀ f : MvPolynomial (Fin n) k, baseLift f ∈ J → + ∀ g ∈ J, poissonBracket (baseLift f) g ∈ J + +/-- Full Poisson closure implies the base-relative fragment. -/ +theorem IsPoisson.isBaseRelativePoisson + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) : + IsBaseRelativePoisson J := by + intro f hf g hg + exact hJ (baseLift f) hf g + +/-- Base-relative closure is preserved through all iterated Hamiltonian brackets. -/ +theorem hamiltonIter_mem_of_isBaseRelativePoisson + (J : Ideal (SymbolRing k n)) (hJ : IsBaseRelativePoisson J) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) : + ∀ m, hamiltonIter f m g ∈ J := by + intro m + induction m with + | zero => exact hg + | succ m hm => exact hJ f hf (hamiltonIter f m g) hm + +/-- +The fibre-line polynomial vanishes under the exact base-relative Gabber +fragment; full Poisson closure is not needed. +-/ +theorem fibreLinePolynomial_eq_zero_of_isBaseRelativePoisson + [CharZero k] + (J : Ideal (SymbolRing k n)) (hJ : IsBaseRelativePoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) : + fibreLinePolynomial y (differentialAt y f) g = 0 := by + apply polynomial_eq_zero_of_eval_iterate_derivative_zero + intro m + rw [iterate_derivative_fibreLinePolynomial, eval_zero_fibreLinePolynomial] + exact hzero _ (hamiltonIter_mem_of_isBaseRelativePoisson J hJ f hf g hg m) + +/-- +A zero-section common zero remains a common zero after translation by +`t df_y`, assuming only `{J ∩ k[x], J} ⊆ J`. +-/ +theorem zeroSection_stable_under_differential_translation_of_isBaseRelativePoisson + [CharZero k] + (J : Ideal (SymbolRing k n)) (hJ : IsBaseRelativePoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) (t : k) : + MvPolynomial.eval (differentialTranslatePoint y f t) g = 0 := by + have heval : + MvPolynomial.eval (differentialTranslatePoint y f t) g = + MvPolynomial.eval (Sum.elim y (fun i => t * differentialAt y f i)) g := by + apply MvPolynomial.eval₂_congr + intro i c hi hc + rcases i with i | i <;> rfl + rw [heval, ← eval_fibreLinePolynomial] + rw [fibreLinePolynomial_eq_zero_of_isBaseRelativePoisson J hJ y hzero f hf g hg] + exact Polynomial.eval_zero + + +end + +end Stafford38.Characteristic.BaseRelativePoisson diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/BaseZeroSection.lean b/LeanPool/Stafford38/Stafford38/Characteristic/BaseZeroSection.lean new file mode 100644 index 0000000000..b0a8067d83 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/BaseZeroSection.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.MvPolynomial.Monad +import LeanPool.Stafford38.Stafford38.Characteristic.ZeroSectionContainment + +/-! +# Zero-section containment over the contracted base zero locus + +The fibre-degree-zero component of a phase-space polynomial is its +specialization at zero fibre coordinates, lifted back from the base ring. +Consequently a common zero of the contracted reduced order-support ideal +already determines a zero-section point of the full reduced support; no +chosen point in the original support fibre is needed. +-/ + +namespace Stafford38.Characteristic.BaseZeroSection + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (n := n) k) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- Set all fibre variables to zero and retain the base variables. -/ +def fibreZeroSpecialization : + SymbolRing k n →ₐ[k] MvPolynomial (Fin n) k := + MvPolynomial.bind₁ (Sum.elim MvPolynomial.X (fun _ => 0)) + +@[simp] +theorem fibreZeroSpecialization_X_base (i : Fin n) : + fibreZeroSpecialization k (MvPolynomial.X (Sum.inl i)) = + MvPolynomial.X i := by + simp [fibreZeroSpecialization] + +@[simp] +theorem fibreZeroSpecialization_X_fibre (i : Fin n) : + fibreZeroSpecialization k (MvPolynomial.X (Sum.inr i)) = 0 := by + simp [fibreZeroSpecialization] + +/-- Evaluating after zero-fibre specialization is evaluation at the +corresponding zero-section point. -/ +theorem eval_fibreZeroSpecialization + (y : Fin n → k) (P : SymbolRing k n) : + MvPolynomial.eval y (fibreZeroSpecialization k P) = + MvPolynomial.eval (zeroSectionPoint y) P := by + change MvPolynomial.aeval y + (MvPolynomial.bind₁ (Sum.elim MvPolynomial.X (fun _ => 0)) P) = _ + rw [MvPolynomial.aeval_bind₁] + apply MvPolynomial.eval₂_congr + intro i c hi hc + rcases i with i | i <;> simp [zeroSectionPoint] + +/-- A base polynomial lifted to phase space evaluates independently of the +fibre coordinate. -/ +theorem eval_baseLift + (y ξ : Fin n → k) (f : MvPolynomial (Fin n) k) : + MvPolynomial.eval (Sum.elim y ξ) (baseLift f) = + MvPolynomial.eval y f := by + change MvPolynomial.aeval (Sum.elim y ξ) + (MvPolynomial.rename Sum.inl f) = _ + rw [MvPolynomial.aeval_rename] + rfl + +/-- The order-degree-zero component is exactly zero-fibre specialization, +viewed again in the phase-space polynomial ring. -/ +theorem zeroComponent_eq_baseLift_fibreZeroSpecialization + (P : SymbolRing k n) : + (DirectSum.decompose (orderDecomposition (n := n) k) P 0 : + SymbolRing k n) = + baseLift (fibreZeroSpecialization k P) := by + induction P using MvPolynomial.induction_on with + | C a => + have hC : MvPolynomial.C a ∈ orderDecomposition (n := n) k 0 := + MvPolynomial.isWeightedHomogeneous_C (@orderWeight n) a + let C0 : orderDecomposition (n := n) k 0 := ⟨MvPolynomial.C a, hC⟩ + have hd := congrArg (fun z => z 0) + (DirectSum.decompose_coe (orderDecomposition (n := n) k) C0) + have hd' : (DirectSum.decompose (orderDecomposition (n := n) k) + (MvPolynomial.C a) 0 : SymbolRing k n) = MvPolynomial.C a := by + simpa [C0] using congrArg Subtype.val hd + rw [hd'] + simp [fibreZeroSpecialization, baseLift] + | add P Q hP hQ => + rw [DirectSum.decompose_add] + change + (DirectSum.decompose (orderDecomposition (n := n) k) P 0 : + SymbolRing k n) + + (DirectSum.decompose (orderDecomposition (n := n) k) Q 0 : + SymbolRing k n) = _ + simp only [map_add, hP, hQ] + | mul_X P i hP => + rcases i with i | i + · have hX : MvPolynomial.X (Sum.inl i : PhaseVar n) ∈ + orderDecomposition (n := n) k 0 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) (Sum.inl i) + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition (n := n) k) hX (Nat.zero_le 0)] + simp only [Nat.zero_sub, map_mul, hP, fibreZeroSpecialization_X_base] + simp [baseLift] + · have hX : MvPolynomial.X (Sum.inr i : PhaseVar n) ∈ + orderDecomposition (n := n) k 1 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) (Sum.inr i) + rw [DirectSum.coe_decompose_mul_of_right_mem_of_not_le + (orderDecomposition (n := n) k) hX (by omega)] + simp + +/-- Every base point of the contracted reduced order-support zero locus lifts +canonically to a zero-section point of the full reduced support. -/ +theorem zeroSection_mem_of_mem_reducedOrderBaseZeroSet + (I : RightIdeal (PresentedWeyl k n)) (y : Fin n → k) + (hy : ∀ f ∈ reducedOrderBaseIdeal k I, + MvPolynomial.eval y f = 0) : + ∀ P ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (zeroSectionPoint y) P = 0 := by + intro P hP + obtain ⟨m, hm⟩ := (mem_reducedOrderSupportIdeal_iff k I P).mp hP + let f := fibreZeroSpecialization k (P ^ m) + have hcomponent : + (DirectSum.decompose (orderDecomposition (n := n) k) (P ^ m) 0 : + SymbolRing k n) ∈ orderInitialIdeal k I := + coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k I 0 + (DirectSum.decompose (orderDecomposition (n := n) k) (P ^ m) 0) + (decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k I (P ^ m) hm 0) + have hbaseLift : baseLift f ∈ reducedOrderSupportIdeal k I := by + rw [← zeroComponent_eq_baseLift_fibreZeroSpecialization] + exact orderInitialIdeal_le_reducedOrderSupportIdeal k I hcomponent + have hfy : MvPolynomial.eval y f = 0 := + hy f ((mem_reducedOrderBaseIdeal_iff k I f).mpr hbaseLift) + have heval : + MvPolynomial.eval (zeroSectionPoint y) (P ^ m) = 0 := by + rw [← eval_fibreZeroSpecialization k y (P ^ m)] + exact hfy + rw [map_pow] at heval + exact (pow_eq_zero_iff'.mp heval).1 + +/-- Field-valued projection is exact: a base point annihilates the contracted +ideal if and only if some fibre point over it annihilates the full reduced +support ideal. The forward witness is canonically the zero fibre. -/ +theorem mem_reducedOrderBaseZeroSet_iff_exists_supportFibre + (I : RightIdeal (PresentedWeyl k n)) (y : Fin n → k) : + (∀ f ∈ reducedOrderBaseIdeal k I, MvPolynomial.eval y f = 0) ↔ + ∃ ξ : Fin n → k, + ∀ P ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (Sum.elim y ξ) P = 0 := by + constructor + · intro hy + refine ⟨0, ?_⟩ + have hpoint : Sum.elim y (0 : Fin n → k) = zeroSectionPoint y := by + funext i + rcases i with i | i <;> rfl + rw [hpoint] + exact zeroSection_mem_of_mem_reducedOrderBaseZeroSet k I y hy + · rintro ⟨ξ, hξ⟩ f hf + have hLift := hξ (baseLift f) + ((mem_reducedOrderBaseIdeal_iff k I f).mp hf) + rw [eval_baseLift k y ξ f] at hLift + exact hLift + + +end + +end Stafford38.Characteristic.BaseZeroSection diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisAvoidanceConsumer.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisAvoidanceConsumer.lean new file mode 100644 index 0000000000..1d675d3e92 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisAvoidanceConsumer.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientGraded +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous +import LeanPool.Stafford38.Stafford38.Weyl.QuotientTransport + +/-! +# Conditional consumer for canonical axis avoidance + +This file assumes, but does not prove, the missing degreewise cancellation +statement for the canonical filtered quotient. It combines that hypothesis +with the proved surjectivity of right multiplication by the distinguished +coordinate and derives strict filtered surjectivity and its associated-graded +form. +-/ + +namespace Stafford38.CanonicalAxisAvoidanceConsumer + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBW +open Stafford38.WeylQuotientTransport + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- The distinguished coordinate belongs to differential order zero. -/ +theorem presentedCoordinate_mem_orderPiece_zero (n : ℕ) : + presentedCoordinate k n ∈ orderPiece k (n + 1) 0 := by + rw [orderPiece, mem_presentedWeightPiece, + presentedCoordinate, presentedNormalFormLinearEquiv_generator] + intro m hm + rw [MvPolynomial.coeff_X'] at hm + split at hm + · next heq => + subst m + simp [monomialWeight, orderWeight, fibreWeight] + · exact (hm rfl).elim + +/-- The exact missing input: multiplication by the coordinate can be +cancelled in every degree of the actual filtered quotient. -/ +def CoordinateCancellation (n N : ℕ) + (d : PresentedWeyl k (n + 1)) : Prop := + ∀ (m : ℕ) (z : PresentedWeyl k (n + 1)), + z ∈ orderPiece k (n + 1) m → + z * presentedCoordinate k n ∈ + rightIdealKSubmodule k (CanonicalIdeal k n N d) ⊔ + presentedStrictLowerPiece k orderWeight m → + z ∈ rightIdealKSubmodule k (CanonicalIdeal k n N d) ⊔ + presentedStrictLowerPiece k orderWeight m + +/-- Cancellation plus unrestricted quotient surjectivity lowers an arbitrary +predecessor until it has no larger order than the target. -/ +theorem exists_strict_coordinate_preimage + (n N m : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : Stafford38.WeylPBWMonicBridge.IsPBWMonicAt k + (.inr (0 : Fin (n + 1))) N d) + (hcancel : CoordinateCancellation k n N d) + (z : PresentedWeyl k (n + 1)) + (hz : z ∈ orderPiece k (n + 1) m) : + ∃ y : PresentedWeyl k (n + 1), + y ∈ orderPiece k (n + 1) m ∧ + qmk (CanonicalIdeal k n N d) (y * presentedCoordinate k n) = + qmk (CanonicalIdeal k n N d) z := by + let I := CanonicalIdeal k n N d + let x := presentedCoordinate k n + have hsurj : Function.Surjective (rightMul I x) := by + exact presentedCanonicalRightQuotient_rightMul_coordinate_surjective + (k := k) n N hd + obtain ⟨q, hq⟩ := hsurj (qmk I z) + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective I q + change rightMul I x (qmk I y) = qmk I z at hq + rw [← qmk_right_mul] at hq + obtain ⟨L, hyL⟩ := exists_mem_orderPiece k y + have hdesc : ∀ L, ∀ y : PresentedWeyl k (n + 1), + y ∈ orderPiece k (n + 1) L → qmk I (y * x) = qmk I z → + ∃ y' : PresentedWeyl k (n + 1), + y' ∈ orderPiece k (n + 1) m ∧ qmk I (y' * x) = qmk I z := by + intro L + induction L using Nat.strong_induction_on with + | h L ih => + intro y hyL hyx + by_cases hLm : L ≤ m + · exact ⟨y, presentedWeightPiece_mono k orderWeight hLm hyL, hyx⟩ + · have hmL : m < L := Nat.lt_of_not_ge hLm + have hzLower : z ∈ presentedStrictLowerPiece k orderWeight L := by + cases L with + | zero => omega + | succ L => + simp only [presentedStrictLowerPiece] + exact presentedWeightPiece_mono k orderWeight (Nat.le_of_lt_succ hmL) hz + have hyxSub : y * x - z ∈ I := + (Submodule.Quotient.eq I).mp hyx + have hyxMem : y * x ∈ + rightIdealKSubmodule k I ⊔ + presentedStrictLowerPiece k orderWeight L := by + rw [show y * x = (y * x - z) + z by abel] + exact Submodule.add_mem _ + (Submodule.mem_sup_left hyxSub) + (Submodule.mem_sup_right hzLower) + have hyMem := hcancel L y hyL hyxMem + obtain ⟨i, hi, l, hl, hil⟩ := Submodule.mem_sup.mp hyMem + cases L with + | zero => omega + | succ L => + simp only [presentedStrictLowerPiece] at hl + have hyl : qmk I y = qmk I l := by + apply (Submodule.Quotient.eq I).2 + rw [← hil] + simpa using hi + have hlx : qmk I (l * x) = qmk I z := by + rw [qmk_right_mul, ← hyl, ← qmk_right_mul] + exact hyx + exact ih L (Nat.lt_succ_self L) l hl hlx + exact hdesc L y hyL hq + +/-- Every actual associated-graded piece has surjective multiplication by +the order-zero coordinate symbol. -/ +theorem canonical_graded_coordinate_surjective + (n N m : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : Stafford38.WeylPBWMonicBridge.IsPBWMonicAt k + (.inr (0 : Fin (n + 1))) N d) + (hcancel : CoordinateCancellation k n N d) : + Function.Surjective + (quotientOrderHomogeneousAction (N := m) (M := 0) + k (CanonicalIdeal k n N d) + (principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨presentedCoordinate k n, + presentedCoordinate_mem_orderPiece_zero k n⟩)) := by + intro q + obtain ⟨z, rfl⟩ := orderPieceToQuotientGraded_surjective + k (CanonicalIdeal k n N d) m q + obtain ⟨y, hy, hyx⟩ := + exists_strict_coordinate_preimage k n N m hd hcancel z z.property + refine ⟨orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m ⟨y, hy⟩, ?_⟩ + rw [quotientOrderHomogeneousAction_mk_mul] + have hyx' : (rightIdealKSubmodule k (CanonicalIdeal k n N d)).mkQ + (y * presentedCoordinate k n) = + (rightIdealKSubmodule k (CanonicalIdeal k n N d)).mkQ z := + congrArg + (filteredRightQuotientEquivRightQuotient k + (CanonicalIdeal k n N d)).symm hyx + apply (Submodule.Quotient.eq _).2 + change (orderPieceToQuotientPiece k (CanonicalIdeal k n N d) m + ⟨y * presentedCoordinate k n, _⟩ : + FilteredRightQuotient k (CanonicalIdeal k n N d)) - + orderPieceToQuotientPiece k (CanonicalIdeal k n N d) m z ∈ + quotientOrderStrictLowerPiece k (CanonicalIdeal k n N d) m + rw [show (orderPieceToQuotientPiece k (CanonicalIdeal k n N d) m + ⟨y * presentedCoordinate k n, _⟩ : + FilteredRightQuotient k (CanonicalIdeal k n N d)) = + (rightIdealKSubmodule k (CanonicalIdeal k n N d)).mkQ + (y * presentedCoordinate k n) from rfl] + rw [show (orderPieceToQuotientPiece k (CanonicalIdeal k n N d) m z : + FilteredRightQuotient k (CanonicalIdeal k n N d)) = + (rightIdealKSubmodule k (CanonicalIdeal k n N d)).mkQ z from rfl] + rw [hyx', sub_self] + exact Submodule.zero_mem _ + +/-- The order-zero principal symbol of the distinguished coordinate is the +corresponding base variable. -/ +theorem coe_coordinate_order_symbol (n : ℕ) : + ((principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨presentedCoordinate k n, + presentedCoordinate_mem_orderPiece_zero k n⟩) : + SymbolRing k (n + 1)) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) := by + ext m + change MvPolynomial.coeff m + (presentedPrincipalComponent k orderWeight 0 + (presentedCoordinate k n)) = _ + rw [coeff_presentedPrincipalComponent, presentedCoordinate, + presentedNormalFormLinearEquiv_generator, MvPolynomial.coeff_X'] + by_cases hm : Finsupp.single (.inl (0 : Fin (n + 1))) 1 = m + · subst m + simp [monomialWeight, orderWeight, fibreWeight] + · simp [hm] + +/-- Conditional scheme-level axis avoidance: the order initial ideal together +with the distinguished coordinate generates the unit ideal. -/ +theorem canonical_orderInitialIdeal_sup_coordinate_eq_top + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : Stafford38.WeylPBWMonicBridge.IsPBWMonicAt k + (.inr (0 : Fin (n + 1))) N d) + (hcancel : CoordinateCancellation k n N d) : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} = ⊤ := by + let I := CanonicalIdeal k n N d + let X : MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := + principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨presentedCoordinate k n, presentedCoordinate_mem_orderPiece_zero k n⟩ + let oneH : MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := + ⟨1, MvPolynomial.isWeightedHomogeneous_one k orderWeight⟩ + have hsurjActual := canonical_graded_coordinate_surjective + k n N 0 hd hcancel + have hsurjSymbol : Function.Surjective + (homogeneousSymbolAction (N := 0) (M := 0) k I X) := by + intro q + obtain ⟨r, hr⟩ := hsurjActual + ((quotientOrderGradedPieceEquivSymbols k I 0).symm q) + refine ⟨quotientOrderGradedPieceEquivSymbols k I 0 r, ?_⟩ + rw [← quotientOrderHomogeneousAction_compatibility] + simpa [I, X] using congrArg + (quotientOrderGradedPieceEquivSymbols k I 0) hr + obtain ⟨q, hq⟩ := hsurjSymbol (Submodule.Quotient.mk oneH) + obtain ⟨P, rfl⟩ := Submodule.Quotient.mk_surjective + (orderSymbolRelation k I 0) q + rw [homogeneousSymbolAction_mk] at hq + have hrel : homogeneousRightMul k X P - oneH ∈ + orderSymbolRelation k I 0 := + (Submodule.Quotient.eq _).mp hq + have hJ : ((homogeneousRightMul k X P - oneH : + MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0) : SymbolRing k (n + 1)) ∈ + orderInitialIdeal k I := + (mem_orderSymbolRelation_iff_coe_mem_orderInitialIdeal k I 0 _).mp hrel + have hJ' : (P : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) - 1 ∈ + orderInitialIdeal k I := by + convert hJ using 1 + simp only [Submodule.coe_sub, coe_homogeneousRightMul, + Submodule.coe_mk] + rw [show (X : SymbolRing k (n + 1)) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) by + exact coe_coordinate_order_symbol k n] + apply (Ideal.eq_top_iff_one _).2 + rw [show (1 : SymbolRing k (n + 1)) = + -((P : SymbolRing k (n + 1)) * MvPolynomial.X (.inl 0) - 1) + + (P : SymbolRing k (n + 1)) * MvPolynomial.X (.inl 0) by ring] + apply Submodule.add_mem + · apply Submodule.mem_sup_left + apply (orderInitialIdeal k I).neg_mem + exact hJ' + · apply Submodule.mem_sup_right + rw [Ideal.mem_span_singleton] + exact ⟨(P : SymbolRing k (n + 1)), by rw [mul_comm]⟩ + +/-- Set-theoretic consequence: the canonical order-characteristic support is +disjoint from the distinguished coordinate hyperplane. -/ +theorem canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : Stafford38.WeylPBWMonicBridge.IsPBWMonicAt k + (.inr (0 : Fin (n + 1))) N d) + (hcancel : CoordinateCancellation k n N d) : + Disjoint + (orderCharacteristicSupport k (CanonicalIdeal k n N d)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + rw [Set.disjoint_left] + intro p hp hpx + rw [orderCharacteristicSupport_eq_zeroLocus, + PrimeSpectrum.mem_zeroLocus] at hp + rw [PrimeSpectrum.mem_zeroLocus] at hpx + have htop := canonical_orderInitialIdeal_sup_coordinate_eq_top + k n N hd hcancel + have hle : orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} ≤ p.asIdeal := + sup_le hp (Ideal.span_le.mpr hpx) + rw [htop] at hle + exact p.2.ne_top (top_unique hle) + + +end + +end Stafford38.CanonicalAxisAvoidanceConsumer diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisMonicInitialTop.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisMonicInitialTop.lean new file mode 100644 index 0000000000..a0fa7cab1e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalAxisMonicInitialTop.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitPreimageFromInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesAction +import LeanPool.Stafford38.Stafford38.Characteristic.HyperplaneRestriction +import LeanPool.Stafford38.Stafford38.Weyl.QuotientTransport + +/-! +# The exact Rees--Koszul form of canonical axis cancellation + +For the canonical quotient `Q = A / (dA + x^N dA)`, PBW monicity already +makes right multiplication by `x` surjective on `Q`. This is the vanishing +of ordinary degree-zero restriction. + +The requested axis-monic initial-ideal theorem is stronger: it says that the +same one-element Koszul restriction vanishes after passing to the actual +order-associated graded module, equivalently after specialization of the +order-Rees module. This file proves that equivalence literally. Thus the +remaining bridge is strict Rees--Koszul base change for this canonical +quotient; ordinary quotient surjectivity is not silently promoted to it. + +No D-module theorem, noncharacteristic pullback theorem, or project axiom is +used here. +-/ + +namespace Stafford38.CanonicalAxisMonicInitialTop + +open Stafford38.CanonicalUnitCoordinatePreimage +open Stafford38.CanonicalUnitPreimageFromInitialTop +open Stafford38.Characteristic +open Stafford38.Characteristic.AssociatedGradedFinite +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientReesAction +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open AlgebraicAnalysis.HyperplaneRestriction +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- The distinguished base-coordinate symbol. -/ +private abbrev AxisCoordinate (n : ℕ) : SymbolRing k (n + 1) := + MvPolynomial.X (.inl (0 : Fin (n + 1))) + +/-- Zeroth Koszul homology of the distinguished coordinate on the actual +order-associated graded canonical quotient. Through the exact Rees special +fibre constructed elsewhere, this is the specialized Rees restriction. -/ +abbrev CanonicalGradedCoordinateKoszulH0 (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + Restriction + (R := SymbolRing k (n + 1)) + (M := OrderAssociatedGradedModule k (CanonicalIdeal k n N d)) + (AxisCoordinate k n) + +/-- Ordinary zeroth Koszul homology of the coordinate on the canonical +filtered quotient, before Rees specialization. -/ +abbrev CanonicalOrdinaryCoordinateKoszulH0 (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + FilteredRightQuotient k (CanonicalIdeal k n N d) ⧸ + LinearMap.range + (filteredRightMul k (CanonicalIdeal k n N d) + (presentedCoordinate k n)) + +/-- The initial-ideal target is exactly surjectivity of coordinate +multiplication on the actual order-associated graded module. Cyclicity is +used in both directions, and the annihilator is the literal order initial +ideal. -/ +theorem canonical_orderInitialIdeal_sup_coordinate_eq_top_iff_graded_surjective + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {AxisCoordinate k n} = ⊤ ↔ + Function.Surjective + (fun q : OrderAssociatedGradedModule k (CanonicalIdeal k n N d) ↦ + AxisCoordinate k n • q) := by + classical + let I := CanonicalIdeal k n N d + let X := AxisCoordinate k n + let g := orderAssociatedGradedGenerator k I + constructor + · intro htop q + obtain ⟨P, rfl⟩ := exists_smul_orderAssociatedGradedGenerator k I q + have hone : (1 : SymbolRing k (n + 1)) ∈ + orderInitialIdeal k I ⊔ Ideal.span {X} := by + rw [htop] + exact Submodule.mem_top + obtain ⟨j, hj, s, hs, hjs⟩ := Submodule.mem_sup.mp hone + obtain ⟨a, ha⟩ := Ideal.mem_span_singleton.mp hs + have hjg : j • g = 0 := + (smul_orderAssociatedGradedGenerator_eq_zero_iff k I j).2 hj + have hsg : s • g = g := by + calc + s • g = (j + s) • g := by rw [add_smul, hjg, zero_add] + _ = 1 • g := congrArg (fun r : SymbolRing k (n + 1) => r • g) hjs + _ = g := one_smul _ _ + refine ⟨(P * a) • g, ?_⟩ + calc + X • ((P * a) • g) = (X * (P * a)) • g := by rw [smul_smul] + _ = (P * s) • g := by rw [ha]; ring + _ = P • (s • g) := by rw [smul_smul] + _ = P • g := by rw [hsg] + · intro hsurj + obtain ⟨q, hq⟩ := hsurj + (orderAssociatedGradedGenerator k I) + obtain ⟨P, hP⟩ := exists_smul_orderAssociatedGradedGenerator k I q + have hq' : X • (P • orderAssociatedGradedGenerator k I) = + orderAssociatedGradedGenerator k I := by + rw [hP] + simpa [X, I] using hq + have hkill : (X * P - 1) • orderAssociatedGradedGenerator k I = 0 := by + rw [sub_smul, mul_smul, hq', one_smul, sub_self] + have hrel : X * P - 1 ∈ orderInitialIdeal k I := + (smul_orderAssociatedGradedGenerator_eq_zero_iff k I (X * P - 1)).1 + hkill + apply (Ideal.eq_top_iff_one _).2 + rw [show (1 : SymbolRing k (n + 1)) = -(X * P - 1) + X * P by ring] + apply Submodule.add_mem + · exact Submodule.mem_sup_left ((orderInitialIdeal k I).neg_mem hrel) + · apply Submodule.mem_sup_right + exact (Ideal.span {X}).mul_mem_right P + (Ideal.subset_span (Set.mem_singleton X)) + +/-- Exact Koszul formulation of the requested theorem: the initial ideal and +the coordinate generate one iff the specialized one-coordinate Koszul +`H₀` is zero. -/ +theorem canonical_orderInitialIdeal_sup_coordinate_eq_top_iff_koszulH0_subsingleton + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {AxisCoordinate k n} = ⊤ ↔ + Subsingleton (CanonicalGradedCoordinateKoszulH0 k n N d) := by + rw [canonical_orderInitialIdeal_sup_coordinate_eq_top_iff_graded_surjective] + exact (restriction_subsingleton_iff_smul_surjective + (R := SymbolRing k (n + 1)) + (M := OrderAssociatedGradedModule k (CanonicalIdeal k n N d)) + (x := AxisCoordinate k n)).symm + +/-- Monicity already kills ordinary coordinate restriction on the literal +canonical right quotient. This is the source side of the still-missing +strict Rees--Koszul base-change theorem. -/ +theorem canonical_ordinary_coordinate_surjective_of_axisMonic + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Function.Surjective + (rightMul (CanonicalIdeal k n N d) (presentedCoordinate k n)) := + presentedCanonicalRightQuotient_rightMul_coordinate_surjective n N hd + +/-- The filtered additive model and the literal regular-right-module quotient +intertwine their written right coordinate actions. -/ +theorem filteredRightQuotientEquivRightQuotient_coordinate + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (q : FilteredRightQuotient k (CanonicalIdeal k n N d)) : + filteredRightQuotientEquivRightQuotient k (CanonicalIdeal k n N d) + (filteredRightMul k (CanonicalIdeal k n N d) + (presentedCoordinate k n) q) = + rightMul (CanonicalIdeal k n N d) (presentedCoordinate k n) + (filteredRightQuotientEquivRightQuotient k + (CanonicalIdeal k n N d) q) := by + refine Submodule.Quotient.induction_on _ q ?_ + intro z + rfl + +/-- PBW monicity makes the ordinary one-coordinate Koszul `H₀` literally +zero. The requested initial-top theorem is the assertion that this remains +true after passing to the order-Rees special fibre. -/ +theorem canonical_ordinary_coordinateKoszulH0_subsingleton_of_axisMonic + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Subsingleton (CanonicalOrdinaryCoordinateKoszulH0 k n N d) := by + rw [Submodule.Quotient.subsingleton_iff] + apply top_unique + intro q hq + let e := filteredRightQuotientEquivRightQuotient k + (CanonicalIdeal k n N d) + obtain ⟨r, hr⟩ := + canonical_ordinary_coordinate_surjective_of_axisMonic k n N hd (e q) + refine ⟨e.symm r, ?_⟩ + apply e.injective + rw [filteredRightQuotientEquivRightQuotient_coordinate] + simpa [e] using hr + +/-- The initial-top statement and the existing strict unit predecessor are +equivalent for the literal canonical quotient. -/ +theorem canonical_orderInitialIdeal_sup_coordinate_eq_top_iff_strictUnit + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {AxisCoordinate k n} = ⊤ ↔ + StrictUnitCoordinatePreimage k n N d := by + constructor + · exact fun h ↦ + strictUnitCoordinatePreimage_of_orderInitialIdeal_sup_coordinate_eq_top + k n N h + · exact fun h ↦ + canonical_orderInitialIdeal_sup_coordinate_eq_top_of_strictUnit + k n N h + + +end + +end Stafford38.CanonicalAxisMonicInitialTop diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalBaseVariety.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalBaseVariety.lean new file mode 100644 index 0000000000..07c2c7964b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalBaseVariety.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisAvoidanceConsumer +import LeanPool.Stafford38.Stafford38.Characteristic.BaseZeroSection +import LeanPool.Stafford38.Stafford38.Characteristic.ReducedSupportIdeal +import Mathlib.RingTheory.Nullstellensatz + +/-! +# The affine base variety feeding the asymptotic argument + +Over an algebraically closed field, nonempty order-characteristic support +forces the contracted reduced base ideal to have a rational point. If the +support avoids the distinguished coordinate hyperplane, every such base point +has nonzero distinguished coordinate. These are exactly the affine premises +of the remaining projective-boundary theorem. +-/ + +namespace Stafford38.Characteristic.CanonicalBaseVariety + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseZeroSection +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable {k : Type u} [Field k] [IsAlgClosed k] {n : ℕ} + +/-- A nonempty reduced order support makes its contracted base ideal proper. -/ +theorem reducedOrderBaseIdeal_ne_top_of_support_nonempty + (I : RightIdeal (PresentedWeyl k n)) + (hsupp : (orderCharacteristicSupport k I).Nonempty) : + reducedOrderBaseIdeal k I ≠ ⊤ := by + rintro htop + rcases hsupp with ⟨p, hp⟩ + have hpReduced : p ∈ PrimeSpectrum.zeroLocus + (reducedOrderSupportIdeal k I : Set (SymbolRing k n)) := by + rw [← orderCharacteristicSupport_eq_zeroLocus_reduced k I] + exact hp + rw [PrimeSpectrum.mem_zeroLocus] at hpReduced + have honeBase : (1 : MvPolynomial (Fin n) k) ∈ + reducedOrderBaseIdeal k I := by rw [htop]; exact Submodule.mem_top + have honeReduced : (1 : SymbolRing k n) ∈ + reducedOrderSupportIdeal k I := by + simpa [baseLift] using + (mem_reducedOrderBaseIdeal_iff k I 1).mp honeBase + exact p.2.ne_top + ((Ideal.eq_top_iff_one p.asIdeal).2 (hpReduced honeReduced)) + +/-- Over an algebraically closed field, nonempty support therefore produces a +ground-field point of the contracted base zero set. -/ +theorem exists_reducedOrderBaseZero_of_support_nonempty + (I : RightIdeal (PresentedWeyl k n)) + (hsupp : (orderCharacteristicSupport k I).Nonempty) : + ∃ y : Fin n → k, + ∀ f ∈ reducedOrderBaseIdeal k I, MvPolynomial.eval y f = 0 := by + let B := reducedOrderBaseIdeal k I + obtain ⟨M, hMmax, hBM⟩ := + Ideal.exists_le_maximal B + (reducedOrderBaseIdeal_ne_top_of_support_nonempty I hsupp) + obtain ⟨y, hMy⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hMmax + refine ⟨y, ?_⟩ + intro f hf + have hfM : f ∈ M := hBM hf + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hfM + exact hfM + +/-- If support avoids the coordinate-zero prime locus, every point of the +contracted base variety has nonzero distinguished coordinate. -/ +theorem coordinate_ne_zero_of_baseZero_of_support_disjoint + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (y : Fin n → k) + (hy : ∀ f ∈ reducedOrderBaseIdeal k I, MvPolynomial.eval y f = 0) : + y i ≠ 0 := by + intro hyi + let q : PhaseVar n → k := zeroSectionPoint y + let p : PrimeSpectrum (SymbolRing k n) := MvPolynomial.pointToPoint q + have hzero : ∀ P ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval q P = 0 := by + exact zeroSection_mem_of_mem_reducedOrderBaseZeroSet k I y hy + have hpSupport : p ∈ orderCharacteristicSupport k I := by + rw [orderCharacteristicSupport_eq_zeroLocus_reduced] + rw [PrimeSpectrum.mem_zeroLocus] + intro P hP + change P ∈ MvPolynomial.vanishingIdeal k {q} + rw [MvPolynomial.mem_vanishingIdeal_singleton_iff] + exact hzero P hP + have hpCoordinate : p ∈ PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)) := by + rw [PrimeSpectrum.mem_zeroLocus] + intro P hP + change P ∈ MvPolynomial.vanishingIdeal k {q} + rw [MvPolynomial.mem_vanishingIdeal_singleton_iff, + Set.mem_singleton_iff.mp hP] + simp [q, zeroSectionPoint, hyi] + exact Set.disjoint_left.mp hdisjoint hpSupport hpCoordinate + +/-- The two affine hypotheses required by the asymptotic boundary theorem: +the base zero set is inhabited and lies in the principal open `X_i ≠ 0`. -/ +theorem exists_baseZero_and_all_coordinate_ne_zero + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (hsupp : (orderCharacteristicSupport k I).Nonempty) : + (∃ y : Fin n → k, + ∀ f ∈ reducedOrderBaseIdeal k I, MvPolynomial.eval y f = 0) ∧ + (∀ y : Fin n → k, + (∀ f ∈ reducedOrderBaseIdeal k I, MvPolynomial.eval y f = 0) → + y i ≠ 0) := by + refine ⟨exists_reducedOrderBaseZero_of_support_nonempty I hsupp, ?_⟩ + intro y hy + exact coordinate_ne_zero_of_baseZero_of_support_disjoint I i hdisjoint y hy + + +end + +end Stafford38.Characteristic.CanonicalBaseVariety diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalCertificate.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalCertificate.lean new file mode 100644 index 0000000000..efa479685d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalCertificate.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.EmptySupportVanishing + +/-! +# Certificate extraction from empty canonical characteristic support + +This file closes the algebraic end of the characteristic-support route. If +the order-characteristic support of the literal canonical quotient is empty, +then that quotient vanishes and membership of `1` in its two-generator right +ideal yields the exact fixed-source Stafford certificate. + +No theorem proving that the support is empty is assumed or supplied here. +-/ + +namespace Stafford38.CharacteristicCanonicalCertificate + +open Stafford38.CharacteristicEmptySupportVanishing +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Empty order-characteristic support of the canonical right ideal gives the +literal fixed-source certificate with source `x^N`. -/ +theorem exists_fixedSource_certificate_of_orderCharacteristicSupport_eq_empty + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hsupport : orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) = ∅) : + ∃ R S : PresentedWeyl k (n + 1), + (1 : PresentedWeyl k (n + 1)) = + d * R + (presentedCoordinate k n) ^ N * d * S := by + let I := canonicalRightIdeal (presentedCoordinate k n) d N + have hquotient : Subsingleton (RightQuotient I) := + rightQuotient_subsingleton_of_orderCharacteristicSupport_eq_empty + k I hsupport + have htop : I = ⊤ := + Submodule.Quotient.subsingleton_iff.mp hquotient + have hone : (1 : PresentedWeyl k (n + 1)) ∈ I := by + rw [htop] + trivial + change (1 : PresentedWeyl k (n + 1)) ∈ + Submodule.span (PresentedWeyl k (n + 1))ᵐᵒᵖ + ({d, (presentedCoordinate k n) ^ N * d} : + Set (PresentedWeyl k (n + 1))) at hone + rcases Submodule.mem_span_pair.mp hone with ⟨r, s, hrs⟩ + refine ⟨r.unop, s.unop, ?_⟩ + simpa [op_smul_eq_mul] using hrs.symm + + +end + +end Stafford38.CharacteristicCanonicalCertificate diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredGradedBridge.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredGradedBridge.lean new file mode 100644 index 0000000000..b5e1ba1c56 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredGradedBridge.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredTwoTerm +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientRees + +/-! +# The degree-zero page of the canonical filtered quotient + +This file records the first genuine page-level bridge: at `p = -m`, the +zero-page source and target are the actual order-`m` quotient graded piece. +-/ + +namespace Stafford38.Characteristic.CanonicalFilteredGradedBridge + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicFilteredQuotientRees +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CI (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +private abbrev K (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + canonicalFilteredTwoTerm k n N d hd + +theorem G_at_neg + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).G (-(m : ℤ)) = + quotientOrderPiece k (CI k n N d) m := by + change (if -(m : ℤ) ≤ 0 then + quotientOrderPiece k (CI k n N d) (- - (m : ℤ)).toNat else ⊥) = _ + rw [if_pos (by omega)] + have hidx : (- - (m : ℤ)).toNat = m := by omega + rw [hidx] + +theorem G_succ_neg + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).G (-(m : ℤ) + 1) = + quotientOrderStrictLowerPiece k (CI k n N d) m := by + by_cases hm : m = 0 + · subst m + norm_num + change (if (1 : ℤ) ≤ 0 then + quotientOrderPiece k (CI k n N d) 1 else + (⊥ : Submodule k (CanonicalQuotient k n N d))) = _ + rw [if_neg (by norm_num)] + rw [quotientOrderStrictLowerPiece] + change (⊥ : Submodule k (CanonicalQuotient k n N d)) = + (presentedStrictLowerPiece k orderWeight 0).map _ + rw [show presentedStrictLowerPiece k orderWeight 0 = ⊥ by rfl] + simp + · obtain ⟨m', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hm + rw [show (-(↑(m' + 1) : ℤ) + 1) = -(m' : ℤ) by omega, + G_at_neg] + rw [quotientOrderStrictLowerPiece_succ_eq] + +theorem zeroPage_source_cycles_eq_orderPiece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).cycles 0 (-(m : ℤ)) = + quotientOrderPiece k (CI k n N d) m := by + rw [FilteredTwoTerm.cycles, G_at_neg k n N m d hd] + apply inf_eq_left.mpr + intro z hz + have hzK : z ∈ (K k n N d hd).G (-(m : ℤ)) := by + rw [G_at_neg k n N m d hd] + exact hz + change (K k n N d hd).f z ∈ (K k n N d hd).G (-(m : ℤ) + 0) + norm_num + apply (K k n N d hd).map_le (-(m : ℤ)) + exact ⟨z, hzK, rfl⟩ + +theorem zeroPage_target_boundaries_eq_orderStrictLowerPiece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).boundaries 0 (-(m : ℤ)) = + quotientOrderStrictLowerPiece k (CI k n N d) m := by + rw [FilteredTwoTerm.boundaries, G_succ_neg k n N m d hd, + G_at_neg k n N m d hd] + norm_num + apply le_trans inf_le_right + rw [← G_succ_neg k n N m d hd] + exact (K k n N d hd).map_le (-(m : ℤ) + 1) + +theorem zeroPage_source_is_actual_graded_piece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).SourcePage 0 (-(m : ℤ)) = + QuotientOrderGradedPiece k (CI k n N d) m := by + change ((K k n N d hd).cycles 0 (-(m : ℤ)) ⧸ _) = _ + rw [zeroPage_source_cycles_eq_orderPiece k n N m d hd] + rw [G_succ_neg k n N m d hd] + +theorem zeroPage_target_is_actual_graded_piece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).TargetPage 0 (-(m : ℤ)) = + QuotientOrderGradedPiece k (CI k n N d) m := by + change ((K k n N d hd).G (-(m : ℤ)) ⧸ _) = _ + rw [G_at_neg k n N m d hd, + zeroPage_target_boundaries_eq_orderStrictLowerPiece k n N m d hd] + +/-- The source component identification, with its actual `k`-linear structure. -/ +def zeroPageSourceLinearEquivOrderGradedPiece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).SourcePage 0 (-(m : ℤ)) ≃ₗ[k] + QuotientOrderGradedPiece k (CI k n N d) m := by + let hC := zeroPage_source_cycles_eq_orderPiece k n N m d hd + let hL := G_succ_neg k n N m d hd + let e := LinearEquiv.ofEq _ _ hC + exact Submodule.Quotient.equiv _ _ e (by + ext x + simp [e, hL]) + +/-- The target component identification, with its actual `k`-linear structure. -/ +def zeroPageTargetLinearEquivOrderGradedPiece + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).TargetPage 0 (-(m : ℤ)) ≃ₗ[k] + QuotientOrderGradedPiece k (CI k n N d) m := by + let hG := G_at_neg k n N m d hd + let hB := zeroPage_target_boundaries_eq_orderStrictLowerPiece k n N m d hd + let e := LinearEquiv.ofEq _ _ hG + exact Submodule.Quotient.equiv _ _ e (by + ext x + simp [e, hB]) + +theorem zeroPage_source_subsingleton_of_pos + (n N : ℕ) (p : ℤ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) (hp : 0 < p) : + Subsingleton ((K k n N d hd).SourcePage 0 p) := by + have hG : (K k n N d hd).G p = ⊥ := + canonicalOrderFiltration_eq_bot_of_pos k _ hp + have hcycles : (K k n N d hd).cycles 0 p = ⊥ := by + apply le_antisymm + · exact le_trans inf_le_left (le_of_eq hG) + · exact bot_le + rw [show (K k n N d hd).SourcePage 0 p = + ((K k n N d hd).cycles 0 p ⧸ + ((K k n N d hd).G (p + 1)).comap + ((K k n N d hd).cycles 0 p).subtype) by rfl, hcycles] + infer_instance + +theorem zeroPage_target_subsingleton_of_pos + (n N : ℕ) (p : ℤ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) (hp : 0 < p) : + Subsingleton ((K k n N d hd).TargetPage 0 p) := by + have hG : (K k n N d hd).G p = ⊥ := + canonicalOrderFiltration_eq_bot_of_pos k _ hp + rw [show (K k n N d hd).TargetPage 0 p = + ((K k n N d hd).G p ⧸ + ((K k n N d hd).boundaries 0 p).comap + ((K k n N d hd).G p).subtype) by rfl, hG] + infer_instance + +theorem zeroPage_drop_representative + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (x : (K k n N d hd).cycles 0 (-(m : ℤ))) : + (K k n N d hd).drop 0 (-(m : ℤ)) + (Submodule.Quotient.mk x) = + Submodule.Quotient.mk + (⟨(K k n N d hd).f (x : CanonicalQuotient k n N d), + x.property.2⟩ : (K k n N d hd).G (-(m : ℤ) + 0)) := by + rw [(K k n N d hd).drop_mk] + rfl + +end +end Stafford38.Characteristic.CanonicalFilteredGradedBridge diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredTwoTerm.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredTwoTerm.lean new file mode 100644 index 0000000000..abb880faf6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalFilteredTwoTerm.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPages +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisAvoidanceConsumer +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule + +/-! +# The canonical filtered two-term complex + +This is the concrete filtered complex used for the canonical Weyl quotient. +The filtration is the actual order filtration on the quotient, extended by +zero in negative order. No associated-graded identification is assumed here. +-/ + +namespace Stafford38.Characteristic.CanonicalFilteredTwoTerm + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylQuotientTransport +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +abbrev CanonicalQuotient (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + FilteredRightQuotient k (CanonicalIdeal k n N d) + +def rightMulLinearMap (I : RightIdeal (PresentedWeyl k (n + 1))) + (a : PresentedWeyl k (n + 1)) : + FilteredRightQuotient k I →ₗ[k] FilteredRightQuotient k I := + Submodule.mapQ (rightIdealKSubmodule k I) (rightIdealKSubmodule k I) + (LinearMap.mulRight k a) (by + intro z hz + exact I.smul_mem (MulOpposite.op a) hz) + +@[simp] theorem rightMulLinearMap_mk + (I : RightIdeal (PresentedWeyl k (n + 1))) + (a z : PresentedWeyl k (n + 1)) : + rightMulLinearMap k I a (Submodule.Quotient.mk z) = + Submodule.Quotient.mk (z * a) := by + change Submodule.Quotient.mk (LinearMap.mulRight k a z) = _ + rfl + +def canonicalOrderFiltration + (I : RightIdeal (PresentedWeyl k (n + 1))) (p : ℤ) : + Submodule k (FilteredRightQuotient k I) := + if hp : p ≤ 0 then quotientOrderPiece k I (-p).toNat else ⊥ + +theorem canonicalOrderFiltration_eq_of_nonpos + (I : RightIdeal (PresentedWeyl k (n + 1))) {p : ℤ} (hp : p ≤ 0) : + canonicalOrderFiltration k I p = quotientOrderPiece k I (-p).toNat := by + simp [canonicalOrderFiltration, hp] + +theorem canonicalOrderFiltration_eq_bot_of_pos + (I : RightIdeal (PresentedWeyl k (n + 1))) {p : ℤ} (hp : 0 < p) : + canonicalOrderFiltration k I p = ⊥ := by + simp [canonicalOrderFiltration, not_le.mpr hp] + +theorem canonicalOrderFiltration_antitone + (I : RightIdeal (PresentedWeyl k (n + 1))) : + Antitone (canonicalOrderFiltration k I) := by + intro p q hpq + by_cases hq : q ≤ 0 + · have hp : p ≤ 0 := le_trans hpq hq + rw [canonicalOrderFiltration_eq_of_nonpos k I hp, + canonicalOrderFiltration_eq_of_nonpos k I hq] + apply Submodule.map_mono + exact presentedWeightPiece_mono k orderWeight (by omega) + · rw [canonicalOrderFiltration_eq_bot_of_pos k I (lt_of_not_ge hq)] + exact bot_le + +theorem canonicalOrderFiltration_exhaustive + (I : RightIdeal (PresentedWeyl k (n + 1))) : + ∀ q : FilteredRightQuotient k I, ∃ p : ℤ, + q ∈ canonicalOrderFiltration k I p := by + intro q + obtain ⟨z, rfl⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k I) q + obtain ⟨m, hm⟩ := exists_mem_orderPiece k z + refine ⟨-(m : ℤ), ?_⟩ + rw [canonicalOrderFiltration_eq_of_nonpos k I (by omega)] + have hidx : (- - (m : ℤ)).toNat = m := by omega + rw [hidx] + change (rightIdealKSubmodule k I).mkQ z ∈ quotientOrderPiece k I m + exact Submodule.mem_map.mpr ⟨z, hm, rfl⟩ + +private theorem quotientOrderPiece_mul_coordinate_mem + (I : RightIdeal (PresentedWeyl k (n + 1))) + {m : ℕ} {q : FilteredRightQuotient k I} + (hq : q ∈ quotientOrderPiece k I m) + (hx : presentedCoordinate k n ∈ orderPiece k (n + 1) 0) : + rightMulLinearMap k I (presentedCoordinate k n) q ∈ + quotientOrderPiece k I m := by + rcases (Submodule.mem_map.mp hq) with ⟨z, hz, rfl⟩ + change rightMulLinearMap k I (presentedCoordinate k n) + (Submodule.Quotient.mk z) ∈ quotientOrderPiece k I m + rw [rightMulLinearMap_mk] + apply Submodule.mem_map.mpr + refine ⟨z * presentedCoordinate k n, mul_mem_orderPiece k hz hx, ?_⟩ + rfl + +def canonicalFilteredTwoTerm (n N : ℕ) + (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + FilteredTwoTerm k (CanonicalQuotient k n N d) where + G := canonicalOrderFiltration k (CanonicalIdeal k n N d) + antitone := canonicalOrderFiltration_antitone k _ + f := rightMulLinearMap k (CanonicalIdeal k n N d) (presentedCoordinate k n) + map_le := by + intro p + by_cases hp : p ≤ 0 + · rw [canonicalOrderFiltration_eq_of_nonpos k _ hp] + apply Submodule.map_le_iff_le_comap.mpr + intro z hz + exact quotientOrderPiece_mul_coordinate_mem k _ hz + (presentedCoordinate_mem_orderPiece_zero k n) + · rw [canonicalOrderFiltration_eq_bot_of_pos k _ (lt_of_not_ge hp)] + simp + +theorem canonicalFilteredTwoTerm_f_surjective + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Function.Surjective + (canonicalFilteredTwoTerm k n N d hd).f := by + intro q + obtain ⟨z, rfl⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k (CanonicalIdeal k n N d)) q + obtain ⟨y, hy⟩ := + presentedCanonicalRightQuotient_rightMul_coordinate_surjective + (k := k) n N hd (qmk (CanonicalIdeal k n N d) z) + obtain ⟨y', hy'⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k (CanonicalIdeal k n N d)) y + rw [← hy'] at hy + refine ⟨Submodule.Quotient.mk y', ?_⟩ + change rightMulLinearMap k (CanonicalIdeal k n N d) + (presentedCoordinate k n) (Submodule.Quotient.mk y') = + Submodule.Quotient.mk z + rw [rightMulLinearMap_mk] + exact hy + + +end +end Stafford38.Characteristic.CanonicalFilteredTwoTerm diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGabberInvolutivityInterface.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGabberInvolutivityInterface.lean new file mode 100644 index 0000000000..2c92eae87b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGabberInvolutivityInterface.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter +import LeanPool.Stafford38.Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity + +/-! +# Lane B: the residue-extension input reduced to the cited Gabber theorem + +The adapter +`Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter` +already reduces `CanonicalResidueExtensionSymbolControl` to +`CanonicalMinimalPrimeInvolutivityOverFields`: involutivity of every minimal +prime of the order initial ideal of the *canonical* quotient, over an +arbitrary characteristic-zero field, with no scalar extension, algebraic +closure, or Laurent series in the statement. Two gaps remained between that +proposition and the literature theorem it is supposed to instantiate. + +* Gabber's theorem is about the radical `√Ann_S gr M`, not about the + individual minimal primes of `Ann_S gr M`. +* Gabber's theorem is about an arbitrary finitely generated filtered module, + so neither `0 < N` nor `IsPBWMonicAt` plays any role in it; the canonical + right ideal `dA + x₀^N dA` is one instance among all right ideals. + +This file closes both. `WeylAssociatedGradedRadicalInvolutivity` is the +citation itself, stated for the repository's actual associated graded object: +for every characteristic-zero field `L`, every `A_m(L)`, and every right ideal +`I`, the radical of `Ann_{S} gr(A/I)` is involutive. It is *intended* to +transcribe the algebraic form of Gabber's theorem proved for +almost-commutative `ℚ`-algebras with Noetherian associated graded +(Singh--Kumar, *On the Involutivity of the Characteristic Variety*, +Comm. Algebra 42 (2014), no. 8, 3607-3618, Theorem 5.1 with Theorems 4.1 and +4.2). +Two things make that transcription plausible: `A/I` is cyclic, so its +order-quotient filtration is good; and the right-module convention costs +nothing, because `A/I` is a left `Aᵒᵖ`-module, `gr(Aᵒᵖ) ≅ (gr A)ᵒᵖ = S` since +`S` is commutative, and the induced bracket only changes sign. + +That this Lean proposition really says what the cited theorem says is a human +review obligation recorded in `docs/literature-assumptions.yaml`, not +something this file establishes. In particular it rests on the repository's +own identification of `OrderAssociatedGradedModule` with `gr(A/I)` for the +differential-order filtration. + +The chain proved here is +`WeylAssociatedGradedRadicalInvolutivity →` +`WeylOrderInitialRadicalInvolutivity →` +`RightWeylMinimalPrimeInvolutivity →` +`CanonicalMinimalPrimeInvolutivityOverFields →` +`CanonicalBaseRelativePoissonOverFields →` +`CanonicalResidueExtensionSymbolControl`, +every step trust-zero. No Gabber-type statement is proved here; the first +proposition is a theorem-shaped interface a caller must still supply. +-/ + +namespace Stafford38.Characteristic.CanonicalGabberInvolutivityInterface + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.CanonicalResidueExtensionAssembly +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +/-- **The cited Gabber theorem, stated on the repository's own associated +graded module.** For every characteristic-zero field `L`, every Weyl algebra +`A_m(L)` with its differential-order filtration, and every right ideal `I`, +the radical of the annihilator of `gr(A/I)` is involutive. + +`A/I` is cyclic, so its quotient filtration is good; this is therefore the +statement of Gabber involutivity, not a project-specific strengthening of it. +It is a theorem-shaped interface: no proof is asserted here. -/ +def WeylAssociatedGradedRadicalInvolutivity : Prop := + ∀ (L : Type u) [Field L] [CharZero L] (m : ℕ) + (I : RightIdeal (PresentedWeyl L m)), + IsInvolutive + (Module.annihilator (SymbolRing L m) + (OrderAssociatedGradedModule L I)).radical + +/-- The same statement written through the order initial ideal, which the +repository proves is exactly that annihilator. -/ +def WeylOrderInitialRadicalInvolutivity : Prop := + ∀ (L : Type u) [Field L] [CharZero L] (m : ℕ) + (I : RightIdeal (PresentedWeyl L m)), + IsInvolutive (orderInitialIdeal L I).radical + +/-- Involutivity of every minimal prime of the order initial ideal, for an +arbitrary right ideal of an arbitrary Weyl algebra over an arbitrary +characteristic-zero field. -/ +def RightWeylMinimalPrimeInvolutivity : Prop := + ∀ (L : Type u) [Field L] [CharZero L] (m : ℕ) + (I : RightIdeal (PresentedWeyl L m)), + ∀ P ∈ (orderInitialIdeal L I).minimalPrimes, IsInvolutive P + +/-- The annihilator form and the initial-ideal form of the citation are the +same proposition. -/ +theorem weylOrderInitialRadicalInvolutivity_iff_associatedGraded : + WeylOrderInitialRadicalInvolutivity.{u} ↔ + WeylAssociatedGradedRadicalInvolutivity.{u} := by + constructor + · intro h L _ _ m I + rw [annihilator_orderAssociatedGradedModule] + exact h L m I + · intro h L _ _ m I + have := h L m I + rwa [annihilator_orderAssociatedGradedModule] at this + +theorem weylOrderInitialRadicalInvolutivity_of_associatedGraded + (h : WeylAssociatedGradedRadicalInvolutivity.{u}) : + WeylOrderInitialRadicalInvolutivity.{u} := + weylOrderInitialRadicalInvolutivity_iff_associatedGraded.mpr h + +/-- Descent from the radical to its minimal primes. This is the step that +removes the mismatch between the citation and the project interface. -/ +theorem rightWeylMinimalPrimeInvolutivity_of_radical + (h : WeylOrderInitialRadicalInvolutivity.{u}) : + RightWeylMinimalPrimeInvolutivity.{u} := by + intro L _ _ m I P hP + exact minimalPrimes_isInvolutive_of_radical_isInvolutive + (orderInitialIdeal L I) (h L m I) P hP + +/-- The canonical right ideal `dA + x₀^N dA` is one right ideal among all of +them, so the generic statement specializes to the lane-B target. Neither +`0 < N` nor `IsPBWMonicAt` is used. -/ +theorem canonicalMinimalPrimeInvolutivityOverFields_of_rightWeyl + (h : RightWeylMinimalPrimeInvolutivity.{u}) : + CanonicalMinimalPrimeInvolutivityOverFields.{u} := by + intro L _ _ n N d _ _ P hP + exact h L (n + 1) _ P hP + +/-- Lane B in one step: residue-extension symbol control from the cited +Gabber theorem for arbitrary right ideals over arbitrary characteristic-zero +fields. -/ +theorem canonicalResidueExtensionSymbolControl_of_associatedGradedRadical + (h : WeylAssociatedGradedRadicalInvolutivity.{u}) : + CanonicalResidueExtensionSymbolControl.{u} := + canonicalResidueExtensionSymbolControl_of_minimalPrimeInvolutivity + (canonicalMinimalPrimeInvolutivityOverFields_of_rightWeyl + (rightWeylMinimalPrimeInvolutivity_of_radical + (weylOrderInitialRadicalInvolutivity_of_associatedGraded h))) + + +end + +end Stafford38.Characteristic.CanonicalGabberInvolutivityInterface diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGradedTangentialEquivalences.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGradedTangentialEquivalences.lean new file mode 100644 index 0000000000..77830bb896 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalGradedTangentialEquivalences.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalOldTangentialFiniteness +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSuccessors + +namespace Stafford38.Characteristic.CanonicalGradedTangentialEquivalences + +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.Characteristic.CanonicalTotalGradedBridge +open Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility +open Stafford38.Characteristic.CanonicalTangentialTotalAction +open Stafford38.Characteristic.CanonicalOldTangentialFiniteness +open Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +open Stafford38.Characteristic.CanonicalTangentialRingEquivalence +open Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +open Stafford38.Characteristic.NormalSymbolPolynomial +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +variable (k : Type*) [Field k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + +abbrev Graded := OrderAssociatedGradedModule k (presentedCanonicalRightIdeal (k := k) n N d) +abbrev T := MvPolynomial (Fin n ⊕ Fin n) k + +local instance gradedModule : Module (T k n) (Graded k n N d) := + oldCoeffModule n (Graded k n N d) + +attribute [local instance] sourceModule targetModule + +theorem graded_C_smul (c : k) (z : Graded k n N d) : + (MvPolynomial.C c : T k n) • z = c • z := by + change (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C).comp + (oldSymbolTangentialAlgEquiv (k := k) n).toRingHom) (MvPolynomial.C c) • z = _ + have hC : (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C).comp + (oldSymbolTangentialAlgEquiv (k := k) n).toRingHom) (MvPolynomial.C c) = + (MvPolynomial.C c : SymbolRing k (n + 1)) := by + simp [tangentialPolynomialActionHom, normalPolynomialActionHom, + normalCoeffTangentialAlgEquiv, normalSymbolAlgEquiv, + oldSymbolTangentialAlgEquiv] + rw [hC] + exact algebraMap_smul (SymbolRing k (n + 1)) c z + +theorem sourceEquiv_map_smul (P : T k n) + (z : (complex k n N d hd).SourceTotal 0) : + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd (P • z) = + P • sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + induction P using MvPolynomial.induction_on generalizing z with + | C c => + rw [graded_C_smul] + change sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (sourceAction k n N d hd 0 (MvPolynomial.C c) z) = _ + rw [sourceAction, commutingPolynomialAction_apply_C] + exact (sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd).map_smul c z + | add P Q hP hQ => simp only [add_smul, map_add, hP, hQ] + | mul_X P i hP => + rw [mul_smul, mul_smul, hP] + congr 1 + change sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (sourceAction k n N d hd 0 (MvPolynomial.X i) z) = _ + rw [sourceAction, commutingPolynomialAction_apply_X, + sourceEquiv_intertwines_generator] + exact (oldCoeffModule_oldSymbol_X_action n (Graded k n N d) i _).symm + +theorem targetEquiv_map_smul (P : T k n) + (z : (complex k n N d hd).TargetTotal 0) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd (P • z) = + P • targetTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + induction P using MvPolynomial.induction_on generalizing z with + | C c => + rw [graded_C_smul] + change targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (targetAction k n N d hd 0 (MvPolynomial.C c) z) = _ + rw [targetAction, commutingPolynomialAction_apply_C] + exact (targetTotal0LinearEquivOrderAssociatedGraded k n N d hd).map_smul c z + | add P Q hP hQ => simp only [add_smul, map_add, hP, hQ] + | mul_X P i hP => + rw [mul_smul, mul_smul, hP] + congr 1 + change targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (targetAction k n N d hd 0 (MvPolynomial.X i) z) = _ + rw [targetAction, commutingPolynomialAction_apply_X, + targetEquiv_intertwines_generator] + exact (oldCoeffModule_oldSymbol_X_action n (Graded k n N d) i _).symm + +def sourceGradedEquiv : + (complex k n N d hd).SourceTotal 0 ≃ₗ[T k n] Graded k n N d := + { (sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd).toAddEquiv with + map_smul' := sourceEquiv_map_smul k n N d hd } + +def targetGradedEquiv : + (complex k n N d hd).TargetTotal 0 ≃ₗ[T k n] Graded k n N d := + { (targetTotal0LinearEquivOrderAssociatedGraded k n N d hd).toAddEquiv with + map_smul' := targetEquiv_map_smul k n N d hd } + + +theorem gradedEquiv_drop (z : (complex k n N d hd).SourceTotal 0) : + targetGradedEquiv k n N d hd (tangentialDrop k n N d hd 0 z) = + oldCoordinateMap (k := k) n (Graded k n N d) (sourceGradedEquiv k n N d hd z) := + totalDrop_zero_intertwines_coordinate k n N d hd z + +def zeroDropKernelEquiv : + (tangentialDrop k n N d hd 0).ker ≃ₗ[T k n] + (oldCoordinateMap (k := k) n (Graded k n N d)).ker := + LinearEquiv.ofBijective + ((sourceGradedEquiv k n N d hd).toLinearMap.domRestrict + (tangentialDrop k n N d hd 0).ker |>.codRestrict + (oldCoordinateMap (k := k) n (Graded k n N d)).ker (fun z => by + exact LinearMap.mem_ker.mpr (by + change oldCoordinateMap (k := k) n (Graded k n N d) + (sourceGradedEquiv k n N d hd z.val) = 0 + rw [← gradedEquiv_drop] + simp only [LinearMap.mem_ker.mp z.property, map_zero]))) + (by + constructor + · intro a b hab + exact Subtype.ext ((sourceGradedEquiv k n N d hd).injective + (congrArg Subtype.val hab)) + · intro z + refine ⟨⟨(sourceGradedEquiv k n N d hd).symm z, ?_⟩, + Subtype.ext ((sourceGradedEquiv k n N d hd).apply_symm_apply z)⟩ + apply LinearMap.mem_ker.mpr + apply (targetGradedEquiv k n N d hd).injective + rw [gradedEquiv_drop, LinearEquiv.apply_symm_apply, map_zero] + exact LinearMap.mem_ker.mp z.property) + +theorem targetGradedEquiv_range : + Submodule.map (targetGradedEquiv k n N d hd).toLinearMap + (tangentialDrop k n N d hd 0).range = + (oldCoordinateMap (k := k) n (Graded k n N d)).range := by + ext z + constructor + · rintro ⟨_, ⟨a, rfl⟩, rfl⟩ + exact ⟨sourceGradedEquiv k n N d hd a, (gradedEquiv_drop k n N d hd a).symm⟩ + · rintro ⟨a, rfl⟩ + refine ⟨tangentialDrop k n N d hd 0 ((sourceGradedEquiv k n N d hd).symm a), + ⟨(sourceGradedEquiv k n N d hd).symm a, rfl⟩, ?_⟩ + simpa only [LinearEquiv.coe_toLinearMap, gradedEquiv_drop, + LinearEquiv.apply_symm_apply] + +def zeroDropCokernelEquiv : + ((complex k n N d hd).TargetTotal 0 ⧸ (tangentialDrop k n N d hd 0).range) + ≃ₗ[T k n] (Graded k n N d ⧸ (oldCoordinateMap (k := k) n (Graded k n N d)).range) := + Submodule.Quotient.equiv _ _ (targetGradedEquiv k n N d hd) + (targetGradedEquiv_range k n N d hd) + +def firstSourceGradedKernelEquiv : + (complex k n N d hd).SourceTotal 1 ≃ₗ[T k n] + (oldCoordinateMap (k := k) n (Graded k n N d)).ker := + tangentialSourceSuccEquiv k n N d hd 0 ≪≫ₗ zeroDropKernelEquiv k n N d hd + +def firstTargetGradedCokernelEquiv : + (complex k n N d hd).TargetTotal 1 ≃ₗ[T k n] + (Graded k n N d ⧸ (oldCoordinateMap (k := k) n (Graded k n N d)).range) := + tangentialTargetSuccEquiv k n N d hd 0 ≪≫ₗ zeroDropCokernelEquiv k n N d hd + +theorem first_pages_finite : + Module.Finite (T k n) ((complex k n N d hd).SourceTotal 1) ∧ + Module.Finite (T k n) ((complex k n N d hd).TargetTotal 1) := by + have hf := canonical_finite_old_coordinate_kernel_cokernel hd + haveI : Module.Finite (T k n) + (oldCoordinateMap (k := k) n (Graded k n N d)).ker := hf.1 + haveI : Module.Finite (T k n) + (Graded k n N d ⧸ (oldCoordinateMap (k := k) n (Graded k n N d)).range) := hf.2 + exact ⟨Module.Finite.equiv (firstSourceGradedKernelEquiv k n N d hd).symm, + Module.Finite.equiv (firstTargetGradedCokernelEquiv k n N d hd).symm⟩ + + +end +end Stafford38.Characteristic.CanonicalGradedTangentialEquivalences diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalKoszulContradiction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalKoszulContradiction.lean new file mode 100644 index 0000000000..60ad800826 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalKoszulContradiction.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGradedTangentialEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalPageEulerInequality +import LeanPool.Stafford38.Stafford38.Characteristic.BaseLocalizedKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.NoncharacteristicMinimalPrime +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalSupportAvoidanceFromCokernel +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalSupportExistence + +namespace Stafford38.Characteristic.CanonicalKoszulContradiction + +open scoped Pointwise +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalGradedTangentialEquivalences +open Stafford38.Characteristic.CanonicalOldTangentialFiniteness +open Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +open Stafford38.Characteristic.CanonicalTangentialRingEquivalence +open Stafford38.Characteristic.CanonicalTangentialTotalAction +open Stafford38.Characteristic.CanonicalPageEulerInequality +open Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +open Stafford38.Characteristic.BaseLocalizedKoszulPositivity +open Stafford38.Characteristic.NoncharacteristicMinimalPrime +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section +variable (k : Type*) [Field k] [CharZero k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hN : 0 < N) (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + +attribute [local instance] sourceModule targetModule + +local instance gradedModule : Module (T k n) (Graded k n N d) := + oldCoeffModule n (Graded k n N d) + +local instance coefficientAlgebra : Algebra (T k n) (SymbolRing k (n + 1)) := + (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C).comp + (oldSymbolTangentialAlgEquiv (k := k) n).toRingHom).toAlgebra + +local instance coefficientTower : + IsScalarTower (T k n) (SymbolRing k (n + 1)) (Graded k n N d) := + IsScalarTower.of_compHom (T k n) (SymbolRing k (n + 1)) (Graded k n N d) + +include hN hd in +/-- At a minimal tangential support prime, the actual page Euler inequality +contradicts the strict coordinate Koszul inequality. -/ +theorem no_minimal_coordinate_cokernel_support + (q : PrimeSpectrum (T k n)) + (hqmem : q ∈ Module.support (T k n) + (Graded k n N d ⧸ (oldCoordinateMap (k := k) n (Graded k n N d)).range)) + (hqmin : ∀ p ∈ Module.support (T k n) + (Graded k n N d ⧸ (oldCoordinateMap (k := k) n (Graded k n N d)).range), + p.asIdeal ≤ q.asIdeal → q.asIdeal ≤ p.asIdeal) : False := by + let E := Graded k n N d + let R := T k n + let C := SymbolRing k (n + 1) + let x : C := MvPolynomial.X (.inl (0 : Fin (n + 1))) + let fC : Module.End C E := LinearMap.lsmul C E x + have hf : fC.restrictScalars R = oldCoordinateMap (k := k) n E := rfl + have hfinite := canonical_finite_old_coordinate_kernel_cokernel hd + haveI : Module.Finite R (fC.restrictScalars R).ker := hfinite.1 + haveI : Module.Finite R (E ⧸ (fC.restrictScalars R).range) := hfinite.2 + have hlength := localized_kernel_and_cokernel_isFiniteLength fC q hqmem hqmin + let S := q.asIdeal.primeCompl + let ek := localizedEquiv S (firstSourceGradedKernelEquiv k n N d hd) + let ec := localizedEquiv S (firstTargetGradedCokernelEquiv k n N d hd) + have hA : IsFiniteLength (Localization S) + (LocalizedModule S ((complex k n N d hd).SourceTotal 1)) := + ek.symm.isFiniteLength hlength.2 + have hB : IsFiniteLength (Localization S) + (LocalizedModule S ((complex k n N d hd).TargetTotal 1)) := + ec.symm.isFiniteLength hlength.1 + have hle := canonicalPage_length_target_le_source k n N d hd S hA hB + rw [ec.length_eq, ek.length_eq] at hle + have hlt := localized_length_cokernel_gt_kernel (R := R) (C := C) (E := E) + x q hqmem hqmin (fun p hp => + canonical_minimalPrime_mem_of_normalCoordinate_false d hN hd hp) + exact (not_lt_of_ge hle) hlt + + +include hN hd in +theorem coordinate_cokernel_subsingleton : + Subsingleton (Graded k n N d ⧸ + (oldCoordinateMap (k := k) n (Graded k n N d)).range) := by + let U := Graded k n N d ⧸ + (oldCoordinateMap (k := k) n (Graded k n N d)).range + haveI : Module.Finite (T k n) U := + (canonical_finite_old_coordinate_kernel_cokernel hd).2 + by_contra h + haveI : Nontrivial U := not_subsingleton_iff_nontrivial.mp h + obtain ⟨q, hqmem, hqmin⟩ := + MinimalSupportExistence.exists_minimal_support_prime (R := T k n) (U := U) + exact no_minimal_coordinate_cokernel_support k n N d hN hd q hqmem hqmin + +include hN hd in +theorem coordinate_quotSMulTop_subsingleton : + Subsingleton (QuotSMulTop + (MvPolynomial.X (.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) + (Graded k n N d)) := by + let C := SymbolRing k (n + 1) + let E := Graded k n N d + let x : C := MvPolynomial.X (.inl (0 : Fin (n + 1))) + let f : Module.End C E := LinearMap.lsmul C E x + have hf : oldCoordinateMap (k := k) n E = f.restrictScalars (T k n) := rfl + have hz := coordinate_cokernel_subsingleton k n N d hN hd + rw [hf, LinearMap.range_restrictScalars] at hz + haveI : Subsingleton (E ⧸ f.range) := + (Submodule.Quotient.restrictScalarsEquiv (T k n) f.range).toEquiv.subsingleton_congr.mp hz + have hrange : f.range = x • (⊤ : Submodule C E) := by + ext z + rw [LinearMap.mem_range, Submodule.mem_smul_pointwise_iff_exists] + simp only [Submodule.mem_top, true_and] + rfl + change Subsingleton (E ⧸ x • (⊤ : Submodule C E)) + rw [← hrange] + infer_instance + +include hN hd in +theorem canonical_support_avoidance : + Disjoint + (Stafford38.CharacteristicTransposedFilteredModuleSupport.transposedOrderAssociatedGradedSupport k + (Stafford38.WeylEulerResidue.canonicalRightIdeal + (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : Set (SymbolRing k (n + 1)))) := + CanonicalSupportAvoidanceFromCokernel.canonical_support_avoidance_of_coordinate_cokernel_subsingleton + k n N d hd (coordinate_quotSMulTop_subsingleton k n N d hN hd) + + +end +end Stafford38.Characteristic.CanonicalKoszulContradiction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalLaurentSymbolControl.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalLaurentSymbolControl.lean new file mode 100644 index 0000000000..c23fdba029 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalLaurentSymbolControl.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Concrete inputs for canonical Laurent symbol control + +The terminal Laurent contradiction asks for a fibre polynomial whose lift is +the canonical order symbol and which vanishes on the scalar-extended equation +conormal locus. The only remaining input for that statement is base-relative +Poisson closure of the geometric reduced support. In particular, this file +proves directly that conormals generated by the scalar extension of the +*ground* base contraction lie in geometric support; no unproved equality with +the post-extension base contraction is needed. +-/ + +namespace Stafford38.Characteristic.CanonicalLaurentSymbolControl + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.BaseZeroSection +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +variable {k : Type u} [Field k] {n : ℕ} + +/-- A phase polynomial supported only on fibre variables comes from a fibre +polynomial by the canonical fibre inclusion. -/ +theorem exists_fibreLift_eq_of_isFibreOnly + (Q : SymbolRing k n) (hQ : IsFibreOnly k Q) : + ∃ P : MvPolynomial (Fin n) k, fibreLift P = Q := by + apply MvPolynomial.exists_rename_eq_of_vars_subset_range Q Sum.inr + Sum.inr_injective + intro i hi + change i ∈ Q.vars at hi + rw [MvPolynomial.mem_vars] at hi + rcases hi with ⟨m, hm, him⟩ + have hcoeff : MvPolynomial.coeff m Q ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + rcases i with i | i + · have hzero := hQ m hcoeff i + exact (Finsupp.mem_support_iff.mp him hzero).elim + · exact ⟨i, rfl⟩ + +/-- The canonical order symbol has a literal fibre-polynomial preimage. -/ +theorem exists_canonical_fibrePolynomial + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + ∃ P : MvPolynomial (Fin (n + 1)) k, + fibreLift P = + presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d := + exists_fibreLift_eq_of_isFibreOnly + (presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d) + (canonical_orderPrincipalComponent_isFibreOnly k n N hd) + +private abbrev orderDecompositionGroundExtension := + MvPolynomial.weightedHomogeneousSubmodule k + (@Stafford38.WeylFiltration.orderWeight n) + +local instance orderGradedAlgebraGroundExtensionInstance : + GradedAlgebra (orderDecompositionGroundExtension (k := k) (n := n)) := + MvPolynomial.weightedGradedAlgebra k + (@Stafford38.WeylFiltration.orderWeight n) + +/-- A geometric zero of the scalar extension of the ground base contraction +lifts to the zero section of the geometric reduced support. This avoids any +claim that scalar extension commutes with the whole base contraction. -/ +theorem zeroSection_mem_geometricReducedSupport_of_groundBaseZero + {K : Type*} [Field K] [Algebra k K] + (W : RightIdeal (PresentedWeyl k n)) (y : Fin n → K) + (hy : ∀ f ∈ reducedOrderBaseIdeal k W, + MvPolynomial.eval₂ (algebraMap k K) y f = 0) : + zeroSectionPoint y ∈ MvPolynomial.zeroLocus K + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) := by + rw [mem_zeroLocus_geometricReducedOrderSupportIdeal_iff] + intro P hP + obtain ⟨m, hm⟩ := (mem_reducedOrderSupportIdeal_iff k W P).mp hP + let f := fibreZeroSpecialization k (P ^ m) + have hcomponent : + (DirectSum.decompose + (orderDecompositionGroundExtension (k := k) (n := n)) (P ^ m) 0 : + SymbolRing k n) ∈ orderInitialIdeal k W := + coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k W 0 + (DirectSum.decompose + (orderDecompositionGroundExtension (k := k) (n := n)) (P ^ m) 0) + (decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k W (P ^ m) hm 0) + have hbaseLift : baseLift f ∈ reducedOrderSupportIdeal k W := by + rw [← zeroComponent_eq_baseLift_fibreZeroSpecialization] + exact orderInitialIdeal_le_reducedOrderSupportIdeal k W hcomponent + have hfbase : f ∈ reducedOrderBaseIdeal k W := + (mem_reducedOrderBaseIdeal_iff k W f).mpr hbaseLift + have hfy := hy f hfbase + have heval : + MvPolynomial.eval (zeroSectionPoint y) + ((scalarPolynomialMap (k := k) (K := K) (PhaseVar n) P) ^ m) = 0 := by + rw [← map_pow, + ← eval_fibreZeroSpecialization K y + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) (P ^ m)), + ← scalarPolynomialMap_fibreZeroSpecialization] + simpa only [eval_scalarPolynomialMap] using hfy + have hp0 : + MvPolynomial.eval (zeroSectionPoint y) + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) P) = 0 := by + exact (pow_eq_zero_iff'.mp (by simpa only [map_pow] using heval)).1 + simpa [eval_scalarPolynomialMap] using hp0 + +/-- Under post-extension base-relative Poisson closure, the conormal locus of +the scalar-extended *ground* base contraction already lies in geometric +support. Equality with the post-extension base contraction is unnecessary. -/ +theorem equationConormalLocus_groundMap_subset_geometricReducedSupport + {K : Type*} [Field K] [Algebra k K] [CharZero K] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson + (geometricReducedOrderSupportIdeal (k := k) (K := K) W)) : + equationConormalLocus + ((reducedOrderBaseIdeal k W).map + (scalarPolynomialMap (k := k) (K := K) (Fin n))) ⊆ + MvPolynomial.zeroLocus K + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) := by + intro q hq + let y : Fin n → K := fun i => q (Sum.inl i) + let xi : Fin n → K := fun i => q (Sum.inr i) + have hy : ∀ f ∈ reducedOrderBaseIdeal k W, + MvPolynomial.eval₂ (algebraMap k K) y f = 0 := + (mem_equationConormalLocus_map_iff + (reducedOrderBaseIdeal k W) q).mp hq |>.1 + have hzero := + zeroSection_mem_geometricReducedSupport_of_groundBaseZero W y hy + have hpoint := affineConormal_coordinatePoint_isCommonZero + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) hJ y hzero + ((reducedOrderBaseIdeal k W).map + (scalarPolynomialMap (k := k) (K := K) (Fin n))) + (fun f ↦ map_baseContraction_le_geometricBaseContraction + (reducedOrderSupportIdeal k W) f.2) + xi hq.2 + have hsplit : Sum.elim y xi = q := by + funext i + rcases i with i | i <;> rfl + rw [← hsplit] + exact hpoint + +/-- The precise post-extension base-relative Gabber input used by the Laurent +symbol argument. -/ +def CanonicalGeometricBaseRelativePoisson : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + IsBaseRelativePoisson + (geometricReducedOrderSupportIdeal + (K := LaurentSeries k) + (canonicalRightIdeal (presentedCoordinate k n) d N)) + +/-- Post-extension Gabber closure produces the packaged Laurent symbol control +consumed by the terminal proof. -/ +theorem canonicalLaurentSymbolControl_of_geometric_inputs + (hgabber : CanonicalGeometricBaseRelativePoisson.{u}) : + CanonicalLaurentSymbolControl.{u} := by + intro k _ _ _ n N d hN hd + letI : CharZero (LaurentSeries k) := + charZero_of_injective_algebraMap + (algebraMap k (LaurentSeries k)).injective + let W := canonicalRightIdeal (presentedCoordinate k n) d N + rcases exists_canonical_fibrePolynomial n N hd with ⟨P, hP⟩ + refine ⟨P, hP, ?_⟩ + intro q hq + have hqSupport : q ∈ MvPolynomial.zeroLocus (LaurentSeries k) + (geometricReducedOrderSupportIdeal + (K := LaurentSeries k) W) := + equationConormalLocus_groundMap_subset_geometricReducedSupport + W (hgabber k n N d hN hd) hq + have hprincipal : presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d ∈ + reducedOrderSupportIdeal k W := + orderInitialIdeal_le_reducedOrderSupportIdeal k W + (canonical_orderPrincipalComponent_mem_initialIdeal k n N hd) + have hmapped : scalarPolynomialMap + (k := k) (K := LaurentSeries k) (PhaseVar (n + 1)) + (presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d) ∈ + geometricReducedOrderSupportIdeal + (K := LaurentSeries k) W := + Ideal.le_radical (Ideal.mem_map_of_mem + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (PhaseVar (n + 1))) hprincipal) + have hzero := hqSupport _ hmapped + rw [← hP] at hzero + simpa only [MvPolynomial.aeval_eq_eval, eval_scalarPolynomialMap] using hzero + + +end + +end Stafford38.Characteristic.CanonicalLaurentSymbolControl diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalMonicSaturation.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalMonicSaturation.lean new file mode 100644 index 0000000000..76479c186f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalMonicSaturation.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNoncharacteristicCancellation +import LeanPool.Stafford38.Stafford38.Weyl.CoordinateCommutatorSymbol +import LeanPool.Stafford38.Stafford38.Weyl.FilteredCommutator + +/-! +# A concrete filtered criterion for canonical monic saturation + +For every degree, ordinary injectivity of coordinate multiplication on the +canonical right quotient, together with coordinate preimages that preserve +strict lower-order pieces, implies the exact cancellation statement on every +actual associated-graded piece. This is an ambient filtered/Ore criterion: +it does not mention the initial ideal or assume its saturation. + +For a Bernstein-monic operator of degree one, commutation with the selected +coordinate is exactly `-1`. Hence the two literal canonical generators +`d` and `x * d` already generate the unit right ideal. This proves coordinate +saturation (and therefore strict noncharacteristic cancellation) without +assuming a generic D-module inverse-image theorem. + +The argument deliberately stops at degree one. For degree at least two, the +same commutator has positive differential order; proving saturation then needs +an order-preserving reduction of those higher commutators. Existing monic Ore +division and the positive Euler residue provide unrestricted coordinate +preimages, but do not provide the strict differential-order estimate isolated +below. +-/ + +namespace Stafford38.CanonicalMonicSaturation + +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.CanonicalNoncharacteristicCancellation +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylCoordinateCommutatorSymbol +open Stafford38.WeylEulerResidue +open Stafford38.WeylFilteredCommutator +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- The concrete filtered estimate missing from unrestricted Euler +surjectivity: every class represented below order `m` has a coordinate +predecessor represented below the same order. This is stated in the ambient +Weyl algebra, not in the associated graded or the initial ideal. -/ +def StrictLowerCoordinatePreimages (n N : ℕ) + (d : PresentedWeyl k (n + 1)) : Prop := + ∀ (m : ℕ) (l : PresentedWeyl k (n + 1)), + l ∈ presentedStrictLowerPiece k orderWeight m → + ∃ y : PresentedWeyl k (n + 1), + y ∈ presentedStrictLowerPiece k orderWeight m ∧ + qmk (CanonicalIdeal k n N d) + (y * presentedCoordinate k n) = + qmk (CanonicalIdeal k n N d) l + +/-- A genuinely general filtered reduction. Ordinary cancellation on the +canonical quotient and strict-order coordinate division together imply the +load-bearing cancellation theorem on every filtration degree. -/ +theorem coordinateCancellation_of_quotient_injective_of_strict_preimages + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hinjective : Function.Injective + (rightMul (CanonicalIdeal k n N d) (presentedCoordinate k n))) + (hstrict : StrictLowerCoordinatePreimages k n N d) : + CoordinateCancellation k n N d := by + intro m z hz hzx + obtain ⟨i, hi, l, hl, hil⟩ := Submodule.mem_sup.mp hzx + obtain ⟨y, hy, hyx⟩ := hstrict m l hl + have hzxl : qmk (CanonicalIdeal k n N d) + (z * presentedCoordinate k n) = + qmk (CanonicalIdeal k n N d) l := by + apply (Submodule.Quotient.eq (CanonicalIdeal k n N d)).2 + rw [← hil] + simpa using hi + have hxy : rightMul (CanonicalIdeal k n N d) + (presentedCoordinate k n) (qmk (CanonicalIdeal k n N d) z) = + rightMul (CanonicalIdeal k n N d) + (presentedCoordinate k n) (qmk (CanonicalIdeal k n N d) y) := by + rw [← qmk_right_mul, ← qmk_right_mul, hzxl, hyx] + have hzy : qmk (CanonicalIdeal k n N d) z = + qmk (CanonicalIdeal k n N d) y := hinjective hxy + have hdiff : z - y ∈ CanonicalIdeal k n N d := + (Submodule.Quotient.eq (CanonicalIdeal k n N d)).mp hzy + rw [show z = (z - y) + y by abel] + exact Submodule.add_mem _ + (Submodule.mem_sup_left hdiff) + (Submodule.mem_sup_right hy) + +/-- Actual-graded form of the general filtered reduction. -/ +theorem canonical_graded_coordinateAction_injective_of_quotient_injective_of_strict_preimages + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hinjective : Function.Injective + (rightMul (CanonicalIdeal k n N d) (presentedCoordinate k n))) + (hstrict : StrictLowerCoordinatePreimages k n N d) : + Function.Injective (canonicalGradedCoordinateAction k n N m d) := by + exact (coordinateCancellation_iff_forall_graded_injective k n N d).mp + (coordinateCancellation_of_quotient_injective_of_strict_preimages + k n N d hinjective hstrict) m + +/-- Monicity supplies the unfiltered version of +`StrictLowerCoordinatePreimages`: every quotient class has some coordinate +predecessor. The absent conclusion is precisely that a lower-order class can +be assigned a lower-order predecessor. -/ +theorem canonical_unrestricted_coordinate_preimages_of_monic + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (z : PresentedWeyl k (n + 1)) : + ∃ y : PresentedWeyl k (n + 1), + qmk (CanonicalIdeal k n N d) + (y * presentedCoordinate k n) = + qmk (CanonicalIdeal k n N d) z := by + have hsurjective := + presentedCanonicalRightQuotient_rightMul_coordinate_surjective + (k := k) n N hd + obtain ⟨q, hq⟩ := hsurjective (qmk (CanonicalIdeal k n N d) z) + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective + (CanonicalIdeal k n N d) q + refine ⟨y, ?_⟩ + rw [qmk_right_mul] + exact hq + +private theorem degree_eq_one_of_order_one_of_fibreOnly + {n : ℕ} {P : SymbolRing k n} {m : PhaseVar n →₀ ℕ} + (hm : MvPolynomial.coeff m P ≠ 0) + (hhom : MvPolynomial.IsWeightedHomogeneous (@orderWeight n) P 1) + (hfibre : IsFibreOnly k P) : + m.degree = 1 := by + have horder : monomialWeight (@orderWeight n) m = 1 := by + exact hhom hm + rw [Finsupp.degree_eq_weight_one, Finsupp.weight_apply] + simp only [smul_eq_mul, mul_one] + rw [monomialWeight] at horder + calc + m.sum (fun _ e ↦ e) = + m.sum (fun i e ↦ e * orderWeight i) := by + apply Finsupp.sum_congr + intro i hi + rcases i with i | i + · have hz := hfibre m hm i + simp [hz, orderWeight, fibreWeight] + · simp [orderWeight, fibreWeight] + _ = 1 := horder + +private theorem exponent_eq_selected_of_order_one_of_selected_ne_zero + {n : ℕ} {P : SymbolRing k n} {m : PhaseVar n →₀ ℕ} + (t : Fin n) + (hm : MvPolynomial.coeff m P ≠ 0) + (hhom : MvPolynomial.IsWeightedHomogeneous (@orderWeight n) P 1) + (hfibre : IsFibreOnly k P) + (hmt : m (.inr t) ≠ 0) : + m = Finsupp.single (.inr t) 1 := by + have hdegree := degree_eq_one_of_order_one_of_fibreOnly k hm hhom hfibre + have hdecomp := Finsupp.single_add_erase (.inr t) m + have hdegdecomp := congrArg Finsupp.degree hdecomp + rw [map_add Finsupp.degree] at hdegdecomp + have hmtle := Finsupp.le_degree (.inr t) m + rw [hdegree] at hmtle + have hmt1 : m (.inr t) = 1 := + Nat.le_antisymm hmtle (Nat.one_le_iff_ne_zero.mpr hmt) + have heraseDegree : (m.erase (.inr t)).degree = 0 := by + simpa [hdegree, hmt1] using hdegdecomp + have herase : m.erase (.inr t) = 0 := + (Finsupp.degree_eq_zero_iff _).mp heraseDegree + rw [← hdecomp, hmt1, herase, add_zero] + +/-- A fibre-only order-homogeneous linear symbol whose selected momentum +coefficient is one has selected partial derivative one. -/ +theorem pderiv_eq_one_of_order_one_fibreOnly + {n : ℕ} (t : Fin n) (P : SymbolRing k n) + (hhom : MvPolynomial.IsWeightedHomogeneous (@orderWeight n) P 1) + (hfibre : IsFibreOnly k P) + (hcoeff : MvPolynomial.coeff (Finsupp.single (.inr t) 1) P = 1) : + MvPolynomial.pderiv (.inr t) P = 1 := by + classical + let Q := P - MvPolynomial.X (.inr t) + have hQt : (.inr t : PhaseVar n) ∉ Q.vars := by + intro ht + rw [MvPolynomial.mem_vars] at ht + obtain ⟨m, hmQ, htm⟩ := ht + have hmQne : MvPolynomial.coeff m Q ≠ 0 := + MvPolynomial.mem_support_iff.mp hmQ + have hmt : m (.inr t) ≠ 0 := Finsupp.mem_support_iff.mp htm + by_cases hm : m = Finsupp.single (.inr t) 1 + · subst m + dsimp [Q] at hmQne + rw [MvPolynomial.coeff_sub, hcoeff, MvPolynomial.coeff_X] at hmQne + simp at hmQne + · have hPzero : MvPolynomial.coeff m P = 0 := by + by_contra hP + exact hm + (exponent_eq_selected_of_order_one_of_selected_ne_zero + k t hP hhom hfibre hmt) + have hXzero : MvPolynomial.coeff m + (MvPolynomial.X (.inr t) : SymbolRing k n) = 0 := by + rw [MvPolynomial.coeff_X] + simp [Ne.symm hm] + dsimp [Q] at hmQne + rw [MvPolynomial.coeff_sub, hPzero, hXzero, sub_zero] at hmQne + exact hmQne rfl + have hQderiv : MvPolynomial.pderiv (.inr t : PhaseVar n) Q = 0 := + MvPolynomial.pderiv_eq_zero_of_notMem_vars hQt + have hdecomp : P = Q + MvPolynomial.X (.inr t) := by + dsimp [Q] + abel + rw [hdecomp, map_add, hQderiv, MvPolynomial.pderiv_X_self, zero_add] + +/-- In canonical Bernstein degree one, the selected coordinate commutator is +the scalar `-1`. This is the strict low-order replacement for the missing +higher-order division estimate. -/ +theorem coordinate_commutator_eq_neg_one_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + Stafford.commutator (presentedCoordinate k n) d = -1 := by + let P := presentedPrincipalComponent k (@orderWeight (n + 1)) 1 d + have hdOrder : d ∈ orderPiece k (n + 1) 1 := + bernsteinPiece_le_orderPiece k (n + 1) 1 hd.1 + have hxOrder : presentedCoordinate k n ∈ orderPiece k (n + 1) 0 := + presentedCoordinate_mem_orderPiece_zero k n + have hcommOrder : + Stafford.commutator (presentedCoordinate k n) d ∈ + orderPiece k (n + 1) 0 := by + simpa using commutator_mem_orderPiece_pred k hxOrder hdOrder + have hhom : MvPolynomial.IsWeightedHomogeneous (@orderWeight (n + 1)) P 1 := by + exact MvPolynomial.weightedHomogeneousComponent_mem _ _ _ + have hfibre : IsFibreOnly k P := + canonical_orderPrincipalComponent_isFibreOnly k n 1 hd + have hcoeff : + MvPolynomial.coeff + (Finsupp.single (.inr (0 : Fin (n + 1))) 1) P = 1 := + canonical_orderPrincipalComponent_pureMomentumCoefficient k n 1 hd + have hpderiv : + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) P = 1 := + pderiv_eq_one_of_order_one_fibreOnly k 0 P hhom hfibre hcoeff + have hprincipal : + presentedPrincipalComponent k (@orderWeight (n + 1)) 0 + (Stafford.commutator (presentedCoordinate k n) d) = -1 := by + rw [principalComponent_coordinate_commutator_arbitrary] + rw [Stafford38.WeylCommutatorSymbol.poissonBracket_newestCoordinate, + hpderiv] + have hnegOneOrder : (-1 : PresentedWeyl k (n + 1)) ∈ + orderPiece k (n + 1) 0 := by + exact (orderPiece k (n + 1) 0).neg_mem + (Stafford38.CharacteristicAssociatedGradedModule.orderPieceOne + (n := n + 1) k).property + have hdiffOrder : + Stafford.commutator (presentedCoordinate k n) d - (-1) ∈ + orderPiece k (n + 1) 0 := + (orderPiece k (n + 1) 0).sub_mem hcommOrder hnegOneOrder + have hdiffPrincipal : + presentedPrincipalComponent k (@orderWeight (n + 1)) 0 + (Stafford.commutator (presentedCoordinate k n) d - (-1)) = 0 := by + rw [map_sub, hprincipal] + change -1 - presentedPrincipalComponent k orderWeight 0 + (-1 : PresentedWeyl k (n + 1)) = 0 + rw [map_neg] + have honepc : presentedPrincipalComponent k orderWeight 0 + (1 : PresentedWeyl k (n + 1)) = 1 := by + exact Stafford38.CharacteristicAssociatedGradedModule.presentedPrincipalComponent_orderPieceOne + (n := n + 1) k + rw [honepc] + simp + have hlower := + (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight (n + 1)) _ hdiffOrder).mp hdiffPrincipal + have hdiff : Stafford.commutator (presentedCoordinate k n) d - (-1) = 0 := by + simpa [presentedStrictLowerPiece] using hlower + exact sub_eq_zero.mp hdiff + +/-- Every canonical degree-one monic presentation is already the unit right +ideal. Both terms in the commutator are literal right-ideal elements. -/ +theorem canonicalRightIdeal_eq_top_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + CanonicalIdeal k n 1 d = ⊤ := by + apply top_unique + intro z hz + have hxd : presentedCoordinate k n * d ∈ CanonicalIdeal k n 1 d := by + simpa using secondGenerator_mem (presentedCoordinate k n) d 1 + have hdx : d * presentedCoordinate k n ∈ CanonicalIdeal k n 1 d := by + exact (CanonicalIdeal k n 1 d).smul_mem + (MulOpposite.op (presentedCoordinate k n)) + (firstGenerator_mem (presentedCoordinate k n) d 1) + have hneg : (-1 : PresentedWeyl k (n + 1)) ∈ CanonicalIdeal k n 1 d := by + rw [← coordinate_commutator_eq_neg_one_degree_one k n hd] + exact (CanonicalIdeal k n 1 d).sub_mem hxd hdx + have hone : (1 : PresentedWeyl k (n + 1)) ∈ CanonicalIdeal k n 1 d := by + simpa using (CanonicalIdeal k n 1 d).neg_mem hneg + simpa using (CanonicalIdeal k n 1 d).smul_mem (MulOpposite.op z) hone + +/-- The ordinary coordinate action on the degree-one canonical quotient is +injective. This is the first half of the general filtered interface. -/ +theorem canonical_quotient_coordinate_injective_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + Function.Injective + (rightMul (CanonicalIdeal k n 1 d) (presentedCoordinate k n)) := by + intro q₁ q₂ hq + obtain ⟨z₁, rfl⟩ := Submodule.Quotient.mk_surjective + (CanonicalIdeal k n 1 d) q₁ + obtain ⟨z₂, rfl⟩ := Submodule.Quotient.mk_surjective + (CanonicalIdeal k n 1 d) q₂ + apply (Submodule.Quotient.eq (CanonicalIdeal k n 1 d)).2 + rw [canonicalRightIdeal_eq_top_degree_one k n hd] + exact Submodule.mem_top + +/-- Strict lower-order coordinate preimages in degree one. Together with +`canonical_quotient_coordinate_injective_degree_one`, this instantiates the +general filtered reduction and makes the unit-ideal case a reusable base +interface rather than an isolated shortcut. -/ +theorem canonical_strictLowerCoordinatePreimages_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + StrictLowerCoordinatePreimages k n 1 d := by + intro m l hl + refine ⟨0, Submodule.zero_mem _, ?_⟩ + apply (Submodule.Quotient.eq (CanonicalIdeal k n 1 d)).2 + rw [canonicalRightIdeal_eq_top_degree_one k n hd] + exact Submodule.mem_top + +/-- The canonical order initial ideal is the unit ideal in degree one. -/ +theorem canonical_orderInitialIdeal_eq_top_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + orderInitialIdeal k (CanonicalIdeal k n 1 d) = ⊤ := by + apply (Ideal.eq_top_iff_one _).2 + have honeI : (1 : PresentedWeyl k (n + 1)) ∈ CanonicalIdeal k n 1 d := by + rw [canonicalRightIdeal_eq_top_degree_one k n hd] + exact Submodule.mem_top + have hone := orderPrincipalComponent_mem_initialIdeal k + (CanonicalIdeal k n 1 d) (1 : PresentedWeyl k (n + 1)) + (Stafford38.CharacteristicAssociatedGradedModule.orderPieceOne + (n := n + 1) k).property honeI + have honepc : presentedPrincipalComponent k orderWeight 0 + (1 : PresentedWeyl k (n + 1)) = 1 := by + exact Stafford38.CharacteristicAssociatedGradedModule.presentedPrincipalComponent_orderPieceOne + (n := n + 1) k + rw [honepc] at hone + exact hone + +/-- **Concrete producer.** For every canonical Bernstein-monic operator of +degree one, the actual order initial ideal is saturated by the selected +coordinate symbol. -/ +theorem canonical_orderInitialIdeal_coordinate_saturated_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + (orderInitialIdeal k (CanonicalIdeal k n 1 d)).colon + ({MvPolynomial.X (Sum.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1))) = + orderInitialIdeal k (CanonicalIdeal k n 1 d) := by + rw [canonical_orderInitialIdeal_eq_top_degree_one k n hd] + apply le_antisymm le_top + intro r hr + rw [Submodule.mem_colon] + intro p hp + exact Submodule.mem_top + +/-- The degree-one producer reaches the actual order-characteristic support. -/ +theorem canonical_orderCharacteristicSupport_eq_empty_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + orderCharacteristicSupport k + (CanonicalIdeal k n 1 d) = ∅ := by + apply (orderCharacteristicSupport_eq_empty_iff k + (CanonicalIdeal k n 1 d)).2 + exact canonical_orderInitialIdeal_eq_top_degree_one k n hd + +/-- The degree-one case yields the literal fixed-source Stafford certificate. -/ +theorem exists_fixedSource_certificate_degree_one + (n : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + ∃ R S : PresentedWeyl k (n + 1), + (1 : PresentedWeyl k (n + 1)) = + d * R + presentedCoordinate k n * d * S := by + let I := CanonicalIdeal k n 1 d + have hone : (1 : PresentedWeyl k (n + 1)) ∈ I := by + change (1 : PresentedWeyl k (n + 1)) ∈ + CanonicalIdeal k n 1 d + rw [canonicalRightIdeal_eq_top_degree_one k n hd] + exact Submodule.mem_top + change (1 : PresentedWeyl k (n + 1)) ∈ + canonicalRightIdeal (presentedCoordinate k n) d 1 at hone + have hone' : (1 : PresentedWeyl k (n + 1)) ∈ + Submodule.span (PresentedWeyl k (n + 1))ᵐᵒᵖ + ({d, presentedCoordinate k n * d} : + Set (PresentedWeyl k (n + 1))) := by + simpa [canonicalRightIdeal, pow_one] using hone + rcases Submodule.mem_span_pair.mp hone' with ⟨r, s, hrs⟩ + refine ⟨r.unop, s.unop, ?_⟩ + simpa [op_smul_eq_mul] using hrs.symm + +/-- Equivalent actual-graded formulation of the degree-one producer. -/ +theorem canonical_graded_coordinateAction_injective_degree_one + (n m : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) 1 d) : + Function.Injective + (canonicalGradedCoordinateAction k n 1 m d) := by + exact + canonical_graded_coordinateAction_injective_of_quotient_injective_of_strict_preimages + k n 1 m d + (canonical_quotient_coordinate_injective_degree_one k n hd) + (canonical_strictLowerCoordinatePreimages_degree_one k n hd) + + +end + +end Stafford38.CanonicalMonicSaturation diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNoncharacteristicCancellation.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNoncharacteristicCancellation.lean new file mode 100644 index 0000000000..b21ae925db --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNoncharacteristicCancellation.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisAvoidanceConsumer + +/-! +# The exact strictness interface for canonical noncharacteristic cancellation + +For the canonical filtered Weyl quotient, the previously isolated +`CoordinateCancellation` condition is not an additional mysterious property: +it is exactly injectivity of the distinguished coordinate on every actual +order-associated-graded piece. This file proves that equivalence and gives a +commutative saturation criterion which is sufficient for it. + +The remaining implication is the load-bearing noncharacteristic theorem: +`IsPBWMonicAt` must force the displayed coordinate action to be injective (or, +equivalently, force saturation of the canonical order initial ideal by the +coordinate). Monicity and unrestricted surjectivity alone do not prove that +strictness statement; no such implication is assumed here. +-/ + +namespace Stafford38.CanonicalNoncharacteristicCancellation + +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- The distinguished coordinate, regarded as a homogeneous order-zero +symbol. -/ +def coordinateOrderSymbol (n : ℕ) : + MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := + principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨presentedCoordinate k n, + presentedCoordinate_mem_orderPiece_zero k n⟩ + +/-- Multiplication by the distinguished coordinate on the actual degree-`m` +associated-graded piece of the canonical filtered quotient. -/ +def canonicalGradedCoordinateAction (n N m : ℕ) + (d : PresentedWeyl k (n + 1)) : + QuotientOrderGradedPiece k (CanonicalIdeal k n N d) m →ₗ[k] + QuotientOrderGradedPiece k (CanonicalIdeal k n N d) m := by + simpa using + (quotientOrderHomogeneousAction (N := m) (M := 0) + k (CanonicalIdeal k n N d) (coordinateOrderSymbol k n)) + +@[simp] theorem canonicalGradedCoordinateAction_mk + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (z : orderPiece k (n + 1) m) : + canonicalGradedCoordinateAction k n N m d + (orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m z) = + orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m + ⟨(z : PresentedWeyl k (n + 1)) * presentedCoordinate k n, + mul_mem_orderPiece k z.property + (presentedCoordinate_mem_orderPiece_zero k n)⟩ := by + change quotientOrderHomogeneousAction k (CanonicalIdeal k n N d) + (coordinateOrderSymbol k n) + (orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m z) = _ + simpa [coordinateOrderSymbol] using + quotientOrderHomogeneousAction_mk_mul k (CanonicalIdeal k n N d) z + ⟨presentedCoordinate k n, + presentedCoordinate_mem_orderPiece_zero k n⟩ + +/-- Degreewise coordinate cancellation is exactly injectivity of coordinate +multiplication on every actual associated-graded quotient piece. Thus the +previously conditional consumer's hypothesis is the strictness part of the +noncharacteristic inverse-image theorem, expressed without any geometric +terminology. -/ +theorem coordinateCancellation_iff_forall_graded_injective + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + CoordinateCancellation k n N d ↔ + ∀ m, Function.Injective + (canonicalGradedCoordinateAction k n N m d) := by + let I := CanonicalIdeal k n N d + let x := presentedCoordinate k n + constructor + · intro hcancel m + rw [← LinearMap.ker_eq_bot] + apply le_antisymm + · intro q hq + obtain ⟨z, rfl⟩ := + orderPieceToQuotientGraded_surjective k I m q + rw [LinearMap.mem_ker] at hq + have hproduct : + (z : PresentedWeyl k (n + 1)) * x ∈ + rightIdealKSubmodule k I ⊔ + presentedStrictLowerPiece k orderWeight m := by + have hproductKer : + ⟨(z : PresentedWeyl k (n + 1)) * x, + mul_mem_orderPiece k z.property + (presentedCoordinate_mem_orderPiece_zero k n)⟩ ∈ + LinearMap.ker (orderPieceToQuotientGraded k I m) := by + rw [LinearMap.mem_ker] + simpa [I, x] using hq + rw [ker_orderPieceToQuotientGraded] at hproductKer + exact hproductKer + have hz := hcancel m z z.property hproduct + rw [Submodule.mem_bot] + rw [← LinearMap.mem_ker, ker_orderPieceToQuotientGraded] + change (z : PresentedWeyl k (n + 1)) ∈ + rightIdealKSubmodule k I ⊔ + presentedStrictLowerPiece k orderWeight m + exact hz + · exact bot_le + · intro hinjective m z hz hzx + let zz : orderPiece k (n + 1) m := ⟨z, hz⟩ + have hproductZero : + orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m + ⟨z * presentedCoordinate k n, + mul_mem_orderPiece k hz + (presentedCoordinate_mem_orderPiece_zero k n)⟩ = 0 := by + rw [← LinearMap.mem_ker, ker_orderPieceToQuotientGraded] + exact hzx + have hzero : + orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m zz = 0 := by + apply hinjective m + rw [map_zero, canonicalGradedCoordinateAction_mk] + exact hproductZero + change z ∈ rightIdealKSubmodule k (CanonicalIdeal k n N d) ⊔ + presentedStrictLowerPiece k orderWeight m + have hzker : zz ∈ LinearMap.ker + (orderPieceToQuotientGraded k (CanonicalIdeal k n N d) m) := by + rw [LinearMap.mem_ker] + exact hzero + rw [ker_orderPieceToQuotientGraded] at hzker + exact hzker + +/-- Saturation of the concrete order initial ideal by the coordinate implies +the exact degreewise cancellation needed by the canonical consumer. This is +a sufficient commutative-algebra formulation of strictness; it is not assumed +to follow from monicity in this file. -/ +theorem coordinateCancellation_of_initialIdeal_coordinate_saturated + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hsaturated : + (orderInitialIdeal k (CanonicalIdeal k n N d)).colon + ({MvPolynomial.X (Sum.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1))) = + orderInitialIdeal k (CanonicalIdeal k n N d)) : + CoordinateCancellation k n N d := by + rw [coordinateCancellation_iff_forall_graded_injective] + intro m + let I := CanonicalIdeal k n N d + let X := coordinateOrderSymbol k n + have hX : (X : SymbolRing k (n + 1)) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) := + coe_coordinate_order_symbol k n + have hsymbol : Function.Injective + (homogeneousSymbolAction (N := m) (M := 0) k I X) := by + rw [← LinearMap.ker_eq_bot] + apply le_antisymm + · intro q hq + rw [LinearMap.mem_ker] at hq + rw [Submodule.mem_bot] + refine Submodule.Quotient.induction_on _ q ?_ hq + intro P hP + rw [homogeneousSymbolAction_mk, + Submodule.Quotient.mk_eq_zero] at hP + have hPX : (P : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ∈ + orderInitialIdeal k I := by + rw [← hX] + exact (mem_orderSymbolRelation_iff_coe_mem_orderInitialIdeal + k I m (homogeneousRightMul k X P)).mp hP + have hPcolon : (P : SymbolRing k (n + 1)) ∈ + (orderInitialIdeal k I).colon + ({MvPolynomial.X (Sum.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1))) := + Submodule.mem_colon_singleton.mpr hPX + have hPJ : (P : SymbolRing k (n + 1)) ∈ orderInitialIdeal k I := by + rw [hsaturated] at hPcolon + exact hPcolon + rw [Submodule.Quotient.mk_eq_zero] + exact (mem_orderSymbolRelation_iff_coe_mem_orderInitialIdeal + k I m P).mpr hPJ + · exact bot_le + intro q₁ q₂ hq + apply (quotientOrderGradedPieceEquivSymbols k I m).injective + apply hsymbol + rw [← quotientOrderHomogeneousAction_compatibility, + ← quotientOrderHomogeneousAction_compatibility] + exact congrArg (quotientOrderGradedPieceEquivSymbols k I m) hq + +/-- A saturated canonical initial ideal therefore satisfies the already +formalized scheme-level coordinate-axis avoidance conclusion. -/ +theorem canonical_support_disjoint_coordinate_zeroLocus_of_saturated + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (hsaturated : + (orderInitialIdeal k (CanonicalIdeal k n N d)).colon + ({MvPolynomial.X (Sum.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1))) = + orderInitialIdeal k (CanonicalIdeal k n N d)) : + Disjoint + (orderCharacteristicSupport k (CanonicalIdeal k n N d)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + exact canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus + k n N hd + (coordinateCancellation_of_initialIdeal_coordinate_saturated + k n N d hsaturated) + + +end + +end Stafford38.CanonicalNoncharacteristicCancellation diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalAxisSupport.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalAxisSupport.lean new file mode 100644 index 0000000000..0fe33d33fa --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalAxisSupport.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Polynomial.DistinguishedVariable +import LeanPool.Stafford38.Stafford38.Characteristic.TransposedFilteredModuleSupport +import LeanPool.Stafford38.Stafford38.Geometry.ConormalAxisContradiction + +/-! +# Scheme-theoretic exclusion of the punctured normal fibre axis + +The canonical order symbol is homogeneous, fibre-only, and has unit pure +normal coefficient. Hence a characteristic-support prime containing every +tangential momentum variable must also contain the normal momentum variable. +This is the exact prime-ideal form of normal-axis exclusion. It proves no +filtered strictness or noncharacteristic inverse-image theorem. +-/ + +namespace Stafford38.Characteristic.CanonicalNormalAxisSupport + +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicTransposedFilteredModuleSupport +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.ConormalAxisContradiction +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylEulerResidue +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylTranspositionFiltration + +noncomputable section + +variable {k : Type*} [Field k] {n N : ℕ} + +/-- The phase variables other than the distinguished normal momentum that may +occur in the canonical principal symbol. -/ +def tangentialMomentumVariables (n : ℕ) : Set (PhaseVar (n + 1)) := + {v | ∃ i : Fin (n + 1), i ≠ 0 ∧ v = .inr i} + +/-- A fibre-only polynomial uses only momentum variables. -/ +theorem vars_subset_momentum_of_isFibreOnly + {P : SymbolRing k (n + 1)} (hP : IsFibreOnly k P) : + (P.vars : Set (PhaseVar (n + 1))) ⊆ Set.range Sum.inr := by + classical + intro v hv + rcases v with i | i + · obtain ⟨m, hm, hmi⟩ := (MvPolynomial.mem_vars _).mp hv + have hzero := hP m (MvPolynomial.mem_support_iff.mp hm) i + exact False.elim ((Finsupp.mem_support_iff.mp hmi) hzero) + · exact ⟨i, rfl⟩ + +/-- The variables of a fibre-only polynomial split into the distinguished +normal momentum and the tangential momenta. -/ +theorem vars_subset_normal_insert_tangential + {P : SymbolRing k (n + 1)} (hP : IsFibreOnly k P) : + (P.vars : Set (PhaseVar (n + 1))) ⊆ + insert (.inr (0 : Fin (n + 1))) (tangentialMomentumVariables n) := by + intro v hv + obtain ⟨i, rfl⟩ := vars_subset_momentum_of_isFibreOnly hP hv + by_cases hi : i = 0 + · left + rw [hi] + · right + exact ⟨i, hi, rfl⟩ + +/-- Every canonical characteristic-support prime containing all tangential +momentum variables contains the distinguished normal momentum variable. -/ +theorem normalMomentum_mem_of_mem_canonicalSupport + (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p : PrimeSpectrum (SymbolRing k (n + 1))} + (hp : p ∈ orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (htan : ∀ i : Fin (n + 1), i ≠ 0 → + MvPolynomial.X (.inr i) ∈ p.asIdeal) : + MvPolynomial.X (.inr (0 : Fin (n + 1))) ∈ p.asIdeal := by + let P := presentedPrincipalComponent k orderWeight N d + have hPmem : P ∈ p.asIdeal := by + rw [orderCharacteristicSupport_eq_zeroLocus, + PrimeSpectrum.mem_zeroLocus] at hp + exact hp (canonical_orderPrincipalComponent_mem_initialIdeal k n N hd) + apply AlgebraicAnalysis.MvPolynomial.X_mem_of_homogeneous_mem_prime + (canonical_orderPrincipalComponent_isHomogeneous n N hd) + (vars_subset_normal_insert_tangential + (canonical_orderPrincipalComponent_isFibreOnly k n N hd)) + (canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd) + isUnit_one p.isPrime hPmem + intro v hv + obtain ⟨i, hi, rfl⟩ := hv + exact htan i hi + +/-- Equivalently, no canonical support prime lies on the punctured normal +momentum axis. -/ +theorem no_canonicalSupport_prime_on_punctured_normal_axis + (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + ¬ ∃ p ∈ orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N), + (∀ i : Fin (n + 1), i ≠ 0 → + MvPolynomial.X (.inr i) ∈ p.asIdeal) ∧ + MvPolynomial.X (.inr (0 : Fin (n + 1))) ∉ p.asIdeal := by + rintro ⟨p, hp, htan, hnormal⟩ + exact hnormal (normalMomentum_mem_of_mem_canonicalSupport d hd hp htan) + +/-- The same punctured-axis exclusion for the transposed associated-graded +support used by the left-module noncharacteristic theorem. -/ +theorem normalMomentum_mem_of_mem_transposedCanonicalSupport + (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p : PrimeSpectrum (SymbolRing k (n + 1))} + (hp : p ∈ transposedOrderAssociatedGradedSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (htan : ∀ i : Fin (n + 1), i ≠ 0 → + MvPolynomial.X (.inr i) ∈ p.asIdeal) : + MvPolynomial.X (.inr (0 : Fin (n + 1))) ∈ p.asIdeal := by + let τ : SymbolRing k (n + 1) →+* SymbolRing k (n + 1) := + (symbolTranspositionEquiv k).toRingEquiv.toRingHom + let q : PrimeSpectrum (SymbolRing k (n + 1)) := + PrimeSpectrum.comap τ p + have hqModule : q ∈ Module.support (SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N)) := by + rw [transposedOrderAssociatedGradedSupport_eq_preimage] at hp + exact hp + have hq : q ∈ orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) := by + rw [orderCharacteristicSupport_eq_zeroLocus] + rw [Module.support_eq_zeroLocus, + annihilator_orderAssociatedGradedModule] at hqModule + exact hqModule + have hqtan : ∀ i : Fin (n + 1), i ≠ 0 → + MvPolynomial.X (.inr i) ∈ q.asIdeal := by + intro i hi + change symbolTransposition k (MvPolynomial.X (.inr i)) ∈ p.asIdeal + rw [symbolTransposition_momentum] + exact p.asIdeal.neg_mem (htan i hi) + have hqnormal := normalMomentum_mem_of_mem_canonicalSupport d hd hq hqtan + change symbolTransposition k + (MvPolynomial.X (.inr (0 : Fin (n + 1)))) ∈ p.asIdeal at hqnormal + rw [symbolTransposition_momentum] at hqnormal + simpa using p.asIdeal.neg_mem hqnormal + +/-- No prime of the transposed canonical support lies on the punctured normal +momentum axis. -/ +theorem no_transposedCanonicalSupport_prime_on_punctured_normal_axis + (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + ¬ ∃ p ∈ transposedOrderAssociatedGradedSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N), + (∀ i : Fin (n + 1), i ≠ 0 → + MvPolynomial.X (.inr i) ∈ p.asIdeal) ∧ + MvPolynomial.X (.inr (0 : Fin (n + 1))) ∉ p.asIdeal := by + rintro ⟨p, hp, htan, hnormal⟩ + exact hnormal + (normalMomentum_mem_of_mem_transposedCanonicalSupport d hd hp htan) + + +end + +end Stafford38.Characteristic.CanonicalNormalAxisSupport diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalSymbolFiniteness.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalSymbolFiniteness.lean new file mode 100644 index 0000000000..4e5a4222e9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalNormalSymbolFiniteness.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.NormalSymbolPolynomial +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.Characteristic.MonicAnnihilatorFinite + +namespace Stafford38.Characteristic.CanonicalNormalSymbolFiniteness + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.Characteristic.NormalSymbolPolynomial +open Stafford38.Characteristic.MonicAnnihilatorFinite +open Stafford38.CharacteristicInitialIdeal +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylEulerResidue +open Stafford38.Geometry.ConormalAxisContradiction + +noncomputable section +variable {k : Type*} [Field k] + +abbrev normalCoeffRing (n : ℕ) := + MvPolynomial {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))} k + +def normalPolynomialActionHom (n : ℕ) : + Polynomial (normalCoeffRing (k := k) n) →+* SymbolRing k (n + 1) := + (normalSymbolAlgEquiv (k := k) n).symm.toRingHom + +/-- The polynomial-ring action obtained by transporting the symbol action +across the normal-variable equivalence. -/ +@[instance_reducible] def normalPolynomialModule (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (Polynomial (normalCoeffRing (k := k) n)) E := + Module.compHom E (normalPolynomialActionHom (k := k) n) + +/-- The corresponding action of the ring of all non-normal symbols. -/ +@[instance_reducible] def normalCoeffModule (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : Module (normalCoeffRing (k := k) n) E := + Module.compHom E + ((normalPolynomialActionHom (k := k) n).comp Polynomial.C) + +/-- The actual canonical order-associated graded module is finite over the +polynomial ring in all symbols except the distinguished normal covariable. -/ +theorem canonical_orderAssociatedGradedModule_finite_normalCoeffRing + {n N : ℕ} {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + @Module.Finite (normalCoeffRing (k := k) n) + (OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + _ _ (normalCoeffModule (k := k) n _) := by + let R := normalCoeffRing (k := k) n + let E := OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N) + let e := normalSymbolAlgEquiv (k := k) n + let g : Polynomial R := canonicalNormalPolynomial (k := k) (n := n) (N := N) d + letI : Module (Polynomial R) E := normalPolynomialModule (k := k) n E + letI : Module R E := normalCoeffModule (k := k) n E + letI : IsScalarTower R (Polynomial R) E := + ⟨by + intro r p z + change (e.symm (r • p)) • z = + e.symm (Polynomial.C r) • e.symm p • z + rw [Polynomial.smul_eq_C_mul, map_mul, mul_smul]⟩ + let generator : E := orderAssociatedGradedGenerator k + (canonicalRightIdeal (presentedCoordinate k n) d N) + let generatorMap : Polynomial R →ₗ[Polynomial R] E := + LinearMap.toSpanSingleton (Polynomial R) E generator + have hsurj : Function.Surjective generatorMap := by + intro z + obtain ⟨P, hP⟩ := exists_smul_orderAssociatedGradedGenerator k + (canonicalRightIdeal (presentedCoordinate k n) d N) z + refine ⟨e P, ?_⟩ + change e.symm (e P) • generator = z + rw [e.symm_apply_apply] + exact hP + letI : Module.Finite (Polynomial R) E := + Module.Finite.of_surjective generatorMap hsurj + apply finite_of_monic_annihilator g + · exact canonicalNormalPolynomial_monic hd + · intro z + change e.symm g • z = 0 + apply Module.mem_annihilator.mp + rw [annihilator_orderAssociatedGradedModule] + change (normalSymbolAlgEquiv (k := k) n).symm + (canonicalNormalPolynomial (k := k) (n := n) (N := N) d) ∈ _ + rw [canonicalNormalPolynomial, + (normalSymbolAlgEquiv (k := k) n).symm_apply_apply] + exact canonical_orderPrincipalComponent_mem_initialIdeal k n N hd + + +end +end Stafford38.Characteristic.CanonicalNormalSymbolFiniteness diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalOldTangentialFiniteness.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalOldTangentialFiniteness.lean new file mode 100644 index 0000000000..25241c9a83 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalOldTangentialFiniteness.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialRingEquivalence + +namespace Stafford38.Characteristic.CanonicalOldTangentialFiniteness + +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +open Stafford38.Characteristic.CanonicalTangentialRingEquivalence +open Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +open Stafford38.Characteristic.NormalSymbolPolynomial +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylPBW +open Stafford38.WeylEulerResidue + +noncomputable section +variable {k : Type*} [Field k] + +abbrev oldTangentialCoeffRing (n : ℕ) := MvPolynomial (Fin n ⊕ Fin n) k + +/- The coefficient action written in the old, non-subtype variables. -/ +@[instance_reducible] def oldCoeffModule + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (oldTangentialCoeffRing (k := k) n) E := + Module.compHom E + (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C).comp + (oldSymbolTangentialAlgEquiv (k := k) n).toRingHom) + +local instance (priority := 10) oldCoeffModuleInstance + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (oldTangentialCoeffRing (k := k) n) E := + oldCoeffModule (k := k) n E + +def oldCoordinateMap (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + E →ₗ[oldTangentialCoeffRing (k := k) n] E := by + refine + { toFun := fun z => + (MvPolynomial.X (Sum.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) • z + map_add' := smul_add _ + map_smul' := ?_ } + intro r z + let a := (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C).comp + (oldSymbolTangentialAlgEquiv (k := k) n).toRingHom) r + change (MvPolynomial.X (Sum.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) • + (a • z) = a • + ((MvPolynomial.X (Sum.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) • z) + rw [← mul_smul, ← mul_smul, mul_comm] + +theorem oldCoordinateMap_apply (n : ℕ) (E : Type*) + [AddCommGroup E] [Module (SymbolRing k (n + 1)) E] (z : E) : + oldCoordinateMap (k := k) n E z = + (MvPolynomial.X (Sum.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) • z := rfl + +theorem oldCoeffModule_oldSymbol_X_action + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] + (i : Fin n ⊕ Fin n) (z : E) : + @SMul.smul (oldTangentialCoeffRing (k := k) n) E + (oldCoeffModule (k := k) n E).toSMul + (MvPolynomial.X i) z = + (MvPolynomial.X (oldIndex i) : SymbolRing k (n + 1)) • z := by + change ((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) + (oldSymbolTangentialAlgEquiv (k := k) n (MvPolynomial.X i)) • z = _ + rw [tangentialCoeffActionHom_oldSymbol_X] + +theorem canonical_finite_old_coordinate_kernel_cokernel + {n N : ℕ} {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + let E := OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N) + Module.Finite (oldTangentialCoeffRing (k := k) n) + (LinearMap.ker (oldCoordinateMap (k := k) n E)) ∧ + Module.Finite (oldTangentialCoeffRing (k := k) n) + (E ⧸ LinearMap.range (oldCoordinateMap (k := k) n E)) := by + let T := oldTangentialCoeffRing (k := k) n + let C := tangentialCoeffRing (k := k) n + let E := OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N) + let e := oldSymbolTangentialAlgEquiv (k := k) n + letI : Algebra T C := e.toRingHom.toAlgebra + letI : Module T C := Module.compHom C e.toRingHom + letI : Module C E := tangentialCoeffModule (k := k) n E + letI : Module T E := oldCoeffModule (k := k) n E + letI : IsScalarTower T C E := ⟨by + intro r c z + change (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) + (e r * c)) • z = + (((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) (e r)) • + ((((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) c) • z) + rw [map_mul, mul_smul]⟩ + haveI : Module.Finite T C := + Module.Finite.of_surjective (Module.compHom.toLinearMap e.toRingHom) e.surjective + let f := tangentialCoordinateMap (k := k) n E + have hf : oldCoordinateMap (k := k) n E = f.restrictScalars T := by + ext z + exact (oldCoordinateMap_apply n E z).trans (tangentialCoordinateMap_apply n E z).symm + have hfinite := canonical_orderAssociatedGradedModule_finite_tangential_coordinate hd + haveI : Module.Finite C f.ker := hfinite.1 + haveI : Module.Finite C (E ⧸ f.range) := hfinite.2 + haveI : Module.Finite T f.ker := Module.Finite.trans C f.ker + haveI : Module.Finite T (E ⧸ f.range) := Module.Finite.trans C (E ⧸ f.range) + change Module.Finite T (oldCoordinateMap (k := k) n E).ker ∧ + Module.Finite T (E ⧸ (oldCoordinateMap (k := k) n E).range) + rw [hf, LinearMap.ker_restrictScalars, LinearMap.range_restrictScalars] + constructor + · exact Module.Finite.equiv + ((Submodule.restrictScalarsEquiv (R := C) (M := E) T f.ker).restrictScalars T).symm + · exact Module.Finite.equiv (Submodule.Quotient.restrictScalarsEquiv T f.range).symm + + +end +end Stafford38.Characteristic.CanonicalOldTangentialFiniteness diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalPageEulerInequality.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalPageEulerInequality.lean new file mode 100644 index 0000000000..3ca5ad2044 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalPageEulerInequality.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSuccessors +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialBoundaryMaps +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.UniformBoundaryVanishing +import LeanPool.Stafford38.Stafford38.Characteristic.TwoTermPageLength + +namespace Stafford38.Characteristic.CanonicalPageEulerInequality +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalTangentialTotalAction +open Stafford38.Characteristic.LocalizedKernelCokernelEquivalences +open Stafford38.Characteristic.TwoTermPageLength +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylIteratedEquivalence +noncomputable section +variable (k : Type*) [Field k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) +variable (S : Submonoid (MvPolynomial (Fin n ⊕ Fin n) k)) +attribute [local instance] sourceModule targetModule +theorem canonicalPage_length_target_le_source : ∀ + (hA0 : IsFiniteLength (Localization S) + (LocalizedModule S ((complex k n N d hd).SourceTotal 1))) + (hC0 : IsFiniteLength (Localization S) + (LocalizedModule S ((complex k n N d hd).TargetTotal 1))), + Module.length (Localization S) (LocalizedModule S ((complex k n N d hd).TargetTotal 1)) ≤ + Module.length (Localization S) (LocalizedModule S ((complex k n N d hd).SourceTotal 1)) := by + intro hA0 hC0 + let A : ℕ → Type _ := fun r => LocalizedModule S ((complex k n N d hd).SourceTotal (r+1)) + let C : ℕ → Type _ := fun r => LocalizedModule S ((complex k n N d hd).TargetTotal (r+1)) + letI : ∀ r, AddCommGroup (A r) := fun r => by dsimp only [A]; infer_instance + letI : ∀ r, Module (Localization S) (A r) := fun r => by dsimp only [A]; infer_instance + letI : ∀ r, AddCommGroup (C r) := fun r => by dsimp only [C]; infer_instance + letI : ∀ r, Module (Localization S) (C r) := fun r => by dsimp only [C]; infer_instance + let dd : ∀ r, A r →ₗ[Localization S] C r := fun r => + localizedMap S (tangentialDrop k n N d hd (r+1)) + have hA0' : IsFiniteLength (Localization S) (A 0) := by simpa [A] using hA0 + have hC0' : IsFiniteLength (Localization S) (C 0) := by simpa [C] using hC0 + have hs : ∀ r, A (r+1) ≃ₗ[Localization S] LinearMap.ker (dd r) := by + intro r + dsimp only [A, dd] + exact (localizedEquiv + (U := (complex k n N d hd).SourceTotal ((r + 1) + 1)) + (V := LinearMap.ker (tangentialDrop k n N d hd (r + 1))) S + (tangentialSourceSuccEquiv k n N d hd (r+1))).trans + (localizedKernelEquiv S (tangentialDrop k n N d hd (r+1))) + have ht : ∀ r, C (r+1) ≃ₗ[Localization S] C r ⧸ LinearMap.range (dd r) := by + intro r + dsimp only [C, dd] + exact (localizedEquiv S (tangentialTargetSuccEquiv k n N d hd (r+1))).trans + (localizedCokernelEquiv S (tangentialDrop k n N d hd (r+1))) + letI : IsNoetherian (Localization S) + (LocalizedModule S ((complex k n N d hd).TargetTotal 1)) := + (isFiniteLength_iff_isNoetherian_isArtinian.mp hC0).1 + obtain ⟨N', hN'⟩ := exists_uniform_subsingleton_localized S + (fun r => tangentialBoundaryMap k n N d hd r) + (tangentialBoundaryMap_ker_mono k n N d hd) + (fun z => tangentialBoundaryMap_eventually_zero k n N d hd z) + (fun r => tangentialBoundaryMap_surjective k n N d hd r) + simpa [A, C] using twoTermPage_length_target_le_source A C hA0' hC0' dd hs ht N' + #print axioms canonicalPage_length_target_le_source + +end +end Stafford38.Characteristic.CanonicalPageEulerInequality diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalResidueExtensionSymbolControlAdapter.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalResidueExtensionSymbolControlAdapter.lean new file mode 100644 index 0000000000..ed7509f116 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalResidueExtensionSymbolControlAdapter.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalLaurentSymbolControl +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportScalarExtension +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimePoisson +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalResidueExtensionAssembly + +/-! +# Residue-extension symbol control from base-relative Poisson closure + +The consumer `equationConormalLocus_groundMap_subset_geometricReducedSupport` +states its scalar extension through `scalarPolynomialMap`, whose coefficient +map is `algebraMap k (LaurentSeries K)`. The terminal interface +`CanonicalResidueExtensionSymbolControl` states its conormal locus through +`groundPolynomialMap`, whose coefficient map is the explicit composite +`(algebraMap K (LaurentSeries K)).comp (algebraMap k K)`. + +Diagnosis (`#synth`, `pp.explicit`): both `Algebra k (LaurentSeries K)` and +`Algebra K (LaurentSeries K)` are the instance +`HahnSeries.powerSeriesAlgebra ℤ K`, whose structure map is +`(ofPowerSeries ℤ K).comp (algebraMap _ (PowerSeries K))`, and the power-series +structure map is `C ∘ algebraMap`. The two coefficient maps are therefore +propositionally equal ring homomorphisms (`groundLaurentMap_eq_algebraMap` +below), even though no `IsScalarTower k K (LaurentSeries K)` instance exists: +the `Algebra`-derived scalar action on `LaurentSeries K` is multiplication by +the structure map, not `HahnSeries.instSMul`. No scalar-tower instance is +constructed or needed here; the bridge is an equality of ring homomorphisms. + +The mathematical content is unchanged from the existing adapter: symbol +control follows from base-relative Poisson closure of the geometric reduced +order support over the same Laurent field `LaurentSeries K`. + +## Reduction to a field-generic Gabber fragment + +`CanonicalResidueExtensionGeometricBaseRelativePoisson` asks for base-relative +Poisson closure of the *geometric* reduced support: the radical of the scalar +extension, to `LaurentSeries K`, of the ground reduced support. The repository +identifies that ideal with the ordinary reduced order support of the +scalar-extended canonical quotient over the field `LaurentSeries K` +(`geometricReducedOrderSupportIdeal_eq_scalarExtension`) and transports PBW +monicity along the same extension. The second section records the exact +consequence: the residue-extension input is implied by a Gabber fragment +stated over an arbitrary characteristic-zero field, with no scalar extension, +algebraic closure, or Laurent series in its statement; and that fragment is +implied by involutivity of every minimal prime of the order initial ideal. + +Nothing here proves any Gabber-type statement; the new predicates are +theorem-shaped interfaces that a caller must still prove. +-/ + +namespace Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.CanonicalLaurentSymbolControl +open Stafford38.Characteristic.GeometricSupportScalarExtension +open Stafford38.Characteristic.MinimalPrimePoisson +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.CanonicalResidueExtensionAssembly +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Weyl.PresentedScalarExtension +open Stafford38.WeylEulerResidue +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +section CoefficientMaps + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-- The explicit composite coefficient map `k → K → LaurentSeries K` is the +structure map of the `Algebra k (LaurentSeries K)` instance. Both sides are +`ofPowerSeries ℤ K ∘ C ∘ algebraMap`, differing only by an identity +`algebraMap K K`. -/ +theorem groundLaurentMap_eq_algebraMap : + groundLaurentMap (k := k) (K := K) = algebraMap k (LaurentSeries K) := by + refine RingHom.ext fun a => ?_ + simp only [groundLaurentMap, RingHom.comp_apply, HahnSeries.algebraMap_apply', + PowerSeries.algebraMap_apply, Algebra.algebraMap_self_apply] + +/-- Consequently the two polynomial coefficient-extension maps agree. -/ +theorem groundPolynomialMap_eq_scalarPolynomialMap (σ : Type*) : + groundPolynomialMap (k := k) (K := K) σ = + scalarPolynomialMap (k := k) (K := LaurentSeries K) σ := by + unfold groundPolynomialMap scalarPolynomialMap + rw [groundLaurentMap_eq_algebraMap] + +/-- The ground equation-conormal locus is the equation-conormal locus of the +`scalarPolynomialMap` extension. -/ +theorem groundEquationConormalLocus_eq {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) : + groundEquationConormalLocus (k := k) (K := K) I = + equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := LaurentSeries K) (Fin n))) := by + unfold groundEquationConormalLocus + rw [groundPolynomialMap_eq_scalarPolynomialMap] + +end CoefficientMaps + +/-- The exact arbitrary-residue-field geometric input. For every field +extension `K/k`, the geometric reduced order support of the canonical quotient +is required to be base-relatively Poisson over `LaurentSeries K`. This is a +theorem-shaped interface, not an axiom: callers must provide a proof of it. +It is stated verbatim as in +`Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter`. -/ +def CanonicalResidueExtensionGeometricBaseRelativePoisson : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (K : Type u) [Field K] [Algebra k K] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + IsBaseRelativePoisson + (geometricReducedOrderSupportIdeal + (K := LaurentSeries K) + (canonicalRightIdeal (presentedCoordinate k n) d N)) + +/-- Arbitrary residue-field symbol control follows from the corresponding +base-relative Poisson statement over the same completed residue field. -/ +theorem canonicalResidueExtensionSymbolControl_of_geometric_inputs + (hgabber : CanonicalResidueExtensionGeometricBaseRelativePoisson.{u}) : + CanonicalResidueExtensionSymbolControl.{u} := by + intro k _ _ _ K _ _ n N d hN hd + have : CharZero K := + charZero_of_injective_algebraMap (algebraMap k K).injective + have : CharZero (LaurentSeries K) := + charZero_of_injective_algebraMap + (algebraMap K (LaurentSeries K)).injective + let W := canonicalRightIdeal (presentedCoordinate k n) d N + rcases exists_canonical_fibrePolynomial n N hd with ⟨P, hP⟩ + refine ⟨P, hP, ?_⟩ + intro q hq + have hq' : q ∈ equationConormalLocus + ((reducedOrderBaseIdeal k W).map + (scalarPolynomialMap (k := k) (K := LaurentSeries K) + (Fin (n + 1)))) := by + rw [groundEquationConormalLocus_eq] at hq + exact hq + have hqSupport : q ∈ MvPolynomial.zeroLocus (LaurentSeries K) + (geometricReducedOrderSupportIdeal + (K := LaurentSeries K) W) := + equationConormalLocus_groundMap_subset_geometricReducedSupport + W (hgabber k K n N d hN hd) hq' + have hprincipal : presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d ∈ + reducedOrderSupportIdeal k W := + orderInitialIdeal_le_reducedOrderSupportIdeal k W + (canonical_orderPrincipalComponent_mem_initialIdeal k n N hd) + have hmapped : scalarPolynomialMap + (k := k) (K := LaurentSeries K) (PhaseVar (n + 1)) + (presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight (n + 1)) N d) ∈ + geometricReducedOrderSupportIdeal + (K := LaurentSeries K) W := + Ideal.le_radical (Ideal.mem_map_of_mem + (scalarPolynomialMap + (k := k) (K := LaurentSeries K) (PhaseVar (n + 1))) hprincipal) + have hzero := hqSupport _ hmapped + rw [← hP] at hzero + rw [groundLaurentMap_eq_algebraMap] + simpa only [MvPolynomial.aeval_eq_eval, eval_scalarPolynomialMap] using hzero + + +/-! ## Reduction to a field-generic Gabber fragment -/ + +/-- The base-relative Gabber fragment for the canonical quotient over an +arbitrary characteristic-zero field. No algebraic closure, scalar extension, +or Laurent series occurs in the statement. -/ +def CanonicalBaseRelativePoissonOverFields : Prop := + ∀ (L : Type u) [Field L] [CharZero L] (n N : ℕ) + (d : PresentedWeyl L (n + 1)), + 0 < N → IsPBWMonicAt L (.inr (0 : Fin (n + 1))) N d → + IsBaseRelativePoisson + (reducedOrderSupportIdeal L + (canonicalRightIdeal (presentedCoordinate L n) d N)) + +/-- Gabber's theorem in its usual form for the canonical quotient over an +arbitrary characteristic-zero field: every minimal prime of the order initial +ideal is involutive. -/ +def CanonicalMinimalPrimeInvolutivityOverFields : Prop := + ∀ (L : Type u) [Field L] [CharZero L] (n N : ℕ) + (d : PresentedWeyl L (n + 1)), + 0 < N → IsPBWMonicAt L (.inr (0 : Fin (n + 1))) N d → + ∀ P ∈ (orderInitialIdeal L + (canonicalRightIdeal (presentedCoordinate L n) d N)).minimalPrimes, + IsInvolutive P + +/-- Minimal-prime involutivity gives the base-relative fragment on the +radical. -/ +theorem canonicalBaseRelativePoissonOverFields_of_minimalPrimeInvolutivity + (h : CanonicalMinimalPrimeInvolutivityOverFields.{u}) : + CanonicalBaseRelativePoissonOverFields.{u} := by + intro L _ _ n N d hN hd + exact radical_isBaseRelativePoisson_of_minimalPrimes_isInvolutive + (orderInitialIdeal L (canonicalRightIdeal (presentedCoordinate L n) d N)) + (h L n N d hN hd) + +/-- The residue-extension geometric input follows from the field-generic +fragment, applied over `LaurentSeries K` to the scalar-extended operator. -/ +theorem canonicalResidueExtensionGeometricBaseRelativePoisson_of_overFields + (h : CanonicalBaseRelativePoissonOverFields.{u}) : + CanonicalResidueExtensionGeometricBaseRelativePoisson.{u} := by + intro k _ _ _ K _ _ n N d hN hd + have : CharZero K := + charZero_of_injective_algebraMap (algebraMap k K).injective + have : CharZero (LaurentSeries K) := + charZero_of_injective_algebraMap + (algebraMap K (LaurentSeries K)).injective + rw [geometricReducedOrderSupportIdeal_eq_scalarExtension + (k := k) (K := LaurentSeries K) n N d] + exact h (LaurentSeries K) n N + (presentedWeylScalarExtension (k := k) (K := LaurentSeries K) (n + 1) d) + hN + (presentedWeylScalarExtension_isPBWMonicAt + (k := k) (K := LaurentSeries K) n N hd) + +/-- Residue-extension symbol control from the field-generic fragment. -/ +theorem canonicalResidueExtensionSymbolControl_of_overFields + (h : CanonicalBaseRelativePoissonOverFields.{u}) : + CanonicalResidueExtensionSymbolControl.{u} := + canonicalResidueExtensionSymbolControl_of_geometric_inputs + (canonicalResidueExtensionGeometricBaseRelativePoisson_of_overFields h) + +/-- Residue-extension symbol control from minimal-prime involutivity over +arbitrary characteristic-zero fields. -/ +theorem canonicalResidueExtensionSymbolControl_of_minimalPrimeInvolutivity + (h : CanonicalMinimalPrimeInvolutivityOverFields.{u}) : + CanonicalResidueExtensionSymbolControl.{u} := + canonicalResidueExtensionSymbolControl_of_overFields + (canonicalBaseRelativePoissonOverFields_of_minimalPrimeInvolutivity h) + + +end + +end Stafford38.Characteristic.CanonicalResidueExtensionSymbolControlAdapter diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalSupportAvoidanceFromCokernel.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalSupportAvoidanceFromCokernel.lean new file mode 100644 index 0000000000..3024786ef5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalSupportAvoidanceFromCokernel.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.TransposedFilteredModuleSupport +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.PaperInputs + +namespace Stafford38.Characteristic.CanonicalSupportAvoidanceFromCokernel + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicTransposedFilteredModuleSupport +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylTranspositionFiltration + +noncomputable section + +universe u +variable (k : Type u) [Field k] + +/-! A zero coordinate cokernel has empty support. Transposition fixes the +coordinate variable, so the same empty-support statement excludes the +coordinate zero locus from the transposed support. -/ +theorem canonical_support_avoidance_of_coordinate_cokernel_subsingleton + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (hzero : Subsingleton (QuotSMulTop + (MvPolynomial.X (.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N)))) : + Disjoint + (transposedOrderAssociatedGradedSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + let R := SymbolRing k (n + 1) + let I := canonicalRightIdeal (presentedCoordinate k n) d N + let E := OrderAssociatedGradedModule k I + let x : R := MvPolynomial.X (.inl (0 : Fin (n + 1))) + let τ : R →+* R := (symbolTranspositionEquiv k).toRingEquiv.toRingHom + let qmod := QuotSMulTop x E + letI : Subsingleton qmod := hzero + have hqempty : Module.support R qmod = ∅ := Module.support_eq_empty + rw [transposedOrderAssociatedGradedSupport_eq_preimage] + apply Set.disjoint_left.2 + intro p hp haxis + let q : PrimeSpectrum R := PrimeSpectrum.comap τ p + have hq : q ∈ Module.support R E := hp + have hqx : q ∈ PrimeSpectrum.zeroLocus ({x} : Set R) := by + rw [PrimeSpectrum.mem_zeroLocus] + intro y hy + have hyx : y = x := by simpa using hy + subst y + change τ x ∈ p.asIdeal + have hτ : τ x = x := by + change symbolTransposition k (MvPolynomial.X (.inl (0 : Fin (n + 1)))) = _ + exact symbolTransposition_coordinate k 0 + rw [hτ] + exact haxis (by simp [x]) + have hqmod : q ∈ Module.support R qmod := by + rw [Module.support_quotSMulTop] + exact ⟨hq, hqx⟩ + rw [hqempty] at hqmod + exact hqmod + +end +end Stafford38.Characteristic.CanonicalSupportAvoidanceFromCokernel diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialBoundaryMaps.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialBoundaryMaps.lean new file mode 100644 index 0000000000..c17defc818 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialBoundaryMaps.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialTotalAction +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryNaturality + +/-! +# Tangential-linear boundary maps for the canonical quotient + +These are the actual quotient maps of the filtered complex, with their +linearity over the tangential polynomial ring proved from the Weyl action. +-/ + +namespace Stafford38.Characteristic.CanonicalTangentialTotalAction + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +variable (k : Type*) [Field k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + +attribute [local instance] sourceModule targetModule + +theorem totalBoundaryMap_intertwines_polynomials (r : ℕ) + (P : MvPolynomial (Fin n ⊕ Fin n) k) : + (complex k n N d hd).totalBoundaryMap r ∘ₗ targetAction k n N d hd 1 P = + targetAction k n N d hd (r + 1) P ∘ₗ + (complex k n N d hd).totalBoundaryMap r := + commutingPolynomialAction_intertwines _ _ _ _ _ + (fun i => (generator k n N d hd i).totalBoundaryMap_naturality r) P + +def tangentialBoundaryMap (r : ℕ) : + (complex k n N d hd).TargetTotal 1 →ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + (complex k n N d hd).TargetTotal (r + 1) where + toFun := (complex k n N d hd).totalBoundaryMap r + map_add' := map_add _ + map_smul' P z := + congrArg (fun f => f z) + (totalBoundaryMap_intertwines_polynomials k n N d hd r P) + +theorem tangentialBoundaryMap_surjective (r : ℕ) : + Function.Surjective (tangentialBoundaryMap k n N d hd r) := + (complex k n N d hd).totalBoundaryMap_surjective r + +theorem tangentialBoundaryMap_ker_mono : + Monotone (fun r => (tangentialBoundaryMap k n N d hd r).ker) := by + intro r s hrs z hz + exact (complex k n N d hd).totalBoundaryMap_ker_mono r s hrs hz + +theorem tangentialBoundaryMap_eventually_zero + (z : (complex k n N d hd).TargetTotal 1) : + ∃ r, tangentialBoundaryMap k n N d hd r z = 0 := + (complex k n N d hd).totalBoundaryMap_eventually_zero + (CanonicalFilteredTwoTerm.canonicalOrderFiltration_exhaustive k _) + (CanonicalFilteredTwoTerm.canonicalFilteredTwoTerm_f_surjective k n N hd) z + + +end +end Stafford38.Characteristic.CanonicalTangentialTotalAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialPageOperators.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialPageOperators.lean new file mode 100644 index 0000000000..f1bcef5210 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialPageOperators.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalActions +import LeanPool.Stafford38.Stafford38.Weyl.FilteredCommutator + +/-! +# Tangential filtered operators on the canonical quotient + +Right multiplication by every tangential Weyl generator gives an actual +filtered operator on the canonical quotient. The distinguished coordinate +commutes with these operators, so they induce operators on every page. +-/ + +namespace Stafford38.Characteristic.CanonicalTangentialPageOperators + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylPBW +open Stafford38.WeylQuotientTransport +open Stafford38.WeylFilteredCommutator + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CI (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +private abbrev K (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + canonicalFilteredTwoTerm k n N d hd + +abbrev PageOperator (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) (e : ℤ) := + (K k n N d hd).PageOperator e + +private theorem oldGenerator_mem_orderPiece + (n : ℕ) (i : Fin n ⊕ Fin n) : + oldGenerator k n i ∈ orderPiece k (n + 1) + (match i with | .inl _ => 0 | .inr _ => 1) := by + cases i with + | inl i => + rw [oldGenerator, orderPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X'] at hm + split at hm + · subst m + simp [oldIndex, monomialWeight, orderWeight, fibreWeight] + · contradiction + | inr i => + rw [oldGenerator, orderPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X'] at hm + split at hm + · subst m + simp [oldIndex, monomialWeight, orderWeight, fibreWeight] + · contradiction + +private theorem rightMul_commute + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (a : PresentedWeyl k (n + 1)) + (ha : a * presentedCoordinate k n = presentedCoordinate k n * a) : + (rightMulLinearMap k (CI k n N d) (presentedCoordinate k n)).comp + (rightMulLinearMap k (CI k n N d) a) = + (rightMulLinearMap k (CI k n N d) a).comp + (rightMulLinearMap k (CI k n N d) (presentedCoordinate k n)) := by + apply LinearMap.ext + intro q + obtain ⟨z, rfl⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k (CI k n N d)) q + rw [LinearMap.comp_apply, LinearMap.comp_apply, + rightMulLinearMap_mk, rightMulLinearMap_mk, rightMulLinearMap_mk, + rightMulLinearMap_mk] + apply congrArg Submodule.Quotient.mk + simp only [mul_assoc] + rw [ha] + +private theorem rightMul_shift + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {e : ℕ} + (a : PresentedWeyl k (n + 1)) (ha : a ∈ orderPiece k (n + 1) e) + {p : ℤ} {q : FilteredRightQuotient k (CI k n N d)} + (hp : p ≤ 0) (hq : q ∈ + canonicalOrderFiltration k (CI k n N d) p) : + rightMulLinearMap k (CI k n N d) a q ∈ + canonicalOrderFiltration k (CI k n N d) (p - (e : ℤ)) := by + rw [canonicalOrderFiltration_eq_of_nonpos k _ hp] at hq + have htarget : p - (e : ℤ) ≤ 0 := by omega + rw [canonicalOrderFiltration_eq_of_nonpos k _ htarget] + have hidx : (-(p - (e : ℤ))).toNat = (-p).toNat + e := by omega + rw [hidx] + rcases Submodule.mem_map.mp hq with ⟨z, hz, rfl⟩ + change rightMulLinearMap k (CI k n N d) a + (Submodule.Quotient.mk z) ∈ _ + rw [rightMulLinearMap_mk] + apply Submodule.mem_map.mpr + refine ⟨z * a, ?_, rfl⟩ + exact mul_mem_orderPiece k hz ha + +def tangentialPageOperator + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (a : PresentedWeyl k (n + 1)) (e : ℕ) + (ha : a ∈ orderPiece k (n + 1) e) + (hax : a * presentedCoordinate k n = presentedCoordinate k n * a) : + PageOperator k n N d hd (e : ℤ) where + g := rightMulLinearMap k (CI k n N d) a + commute := rightMul_commute k n N d a hax + shift := by + intro p q hq + by_cases hp : p ≤ 0 + · exact rightMul_shift k n N d hd (a := a) ha hp hq + · change q ∈ canonicalOrderFiltration k (CI k n N d) p at hq + rw [canonicalOrderFiltration_eq_bot_of_pos k _ (lt_of_not_ge hp)] at hq + subst q + rw [map_zero] + exact Submodule.zero_mem _ + +def tangential_coordinate_pageOperator + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (i : Fin n) : + PageOperator k n N d hd 0 := by + apply tangentialPageOperator k n N d hd + (oldGenerator k n (.inl i)) 0 + · simpa using oldGenerator_mem_orderPiece k n (.inl i) + · exact (presentedCoordinate_commutes_oldGenerator k n (.inl i)).symm + +def tangential_momentum_pageOperator + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (i : Fin n) : + PageOperator k n N d hd 1 := by + apply tangentialPageOperator k n N d hd + (oldGenerator k n (.inr i)) 1 + · simpa using oldGenerator_mem_orderPiece k n (.inr i) + · exact (presentedCoordinate_commutes_oldGenerator k n (.inr i)).symm + + +def tangentialDegree : (Fin n ⊕ Fin n) → ℕ + | .inl _ => 0 + | .inr _ => 1 + +private theorem rightMul_zero (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (z : CanonicalQuotient k n N d) : + rightMulLinearMap k (CI k n N d) 0 z = 0 := by + obtain ⟨w, rfl⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k (CI k n N d)) z + rw [rightMulLinearMap_mk, mul_zero] + simp + +private theorem rightMul_commutator_apply + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (a b : PresentedWeyl k (n + 1)) (q : CanonicalQuotient k n N d) : + rightMulLinearMap k (CI k n N d) a + (rightMulLinearMap k (CI k n N d) b q) - + rightMulLinearMap k (CI k n N d) b + (rightMulLinearMap k (CI k n N d) a q) = + rightMulLinearMap k (CI k n N d) (b * a - a * b) q := by + obtain ⟨z, rfl⟩ := Submodule.Quotient.mk_surjective + (rightIdealKSubmodule k (CI k n N d)) q + change Submodule.Quotient.mk (z * b * a) - + Submodule.Quotient.mk (z * a * b) = + Submodule.Quotient.mk (z * (b * a - a * b)) + rw [mul_sub] + rw [← Submodule.Quotient.mk_sub] + congr 1 + noncomm_ring + +private theorem rightMul_lower_of_orderPiece + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {e : ℕ} (a : PresentedWeyl k (n + 1)) + (ha : a ∈ orderPiece k (n + 1) e) {p : ℤ} + {z : CanonicalQuotient k n N d} + (hz : z ∈ (K k n N d hd).G p) : + rightMulLinearMap k (CI k n N d) a z ∈ + (K k n N d hd).G (p - (e : ℤ)) := by + change z ∈ canonicalOrderFiltration k (CI k n N d) p at hz + change rightMulLinearMap k (CI k n N d) a z ∈ + canonicalOrderFiltration k (CI k n N d) (p - (e : ℤ)) + by_cases hp : p ≤ 0 + · exact rightMul_shift k n N d hd (a := a) ha hp hz + · rw [canonicalOrderFiltration_eq_bot_of_pos k _ (lt_of_not_ge hp)] at hz + have hz0 : z = 0 := by simpa using hz + subst z + rw [map_zero] + exact Submodule.zero_mem _ + +theorem tangential_commutator_lower + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (i j : Fin n ⊕ Fin n) (p : ℤ) + (z : CanonicalQuotient k n N d) + (hz : z ∈ (K k n N d hd).G p) : + (rightMulLinearMap k (CI k n N d) (oldGenerator k n i)) + (rightMulLinearMap k (CI k n N d) (oldGenerator k n j) z) - + (rightMulLinearMap k (CI k n N d) (oldGenerator k n j)) + (rightMulLinearMap k (CI k n N d) (oldGenerator k n i) z) ∈ + (K k n N d hd).G + (p - (tangentialDegree i + tangentialDegree j : ℤ) + 1) := by + rcases i with i | i <;> rcases j with j | j + · have hxi := oldGenerator_mem_orderPiece k n (.inl i) + have hxj := oldGenerator_mem_orderPiece k n (.inl j) + have hc := commutator_mem_orderPiece_pred k hxi hxj + have hzero : oldGenerator k n (.inl j) * oldGenerator k n (.inl i) - + oldGenerator k n (.inl i) * oldGenerator k n (.inl j) = 0 := by + calc + _ = -(Stafford.commutator (oldGenerator k n (.inl i)) + (oldGenerator k n (.inl j))) := by simp [Stafford.commutator] + _ = 0 := by rw [oldGenerator_commutator]; simp [Matrix.J] + rw [rightMul_commutator_apply, hzero] + have hr : rightMulLinearMap k (CI k n N d) + (0 : PresentedWeyl k (n + 1)) z = 0 := rightMul_zero k n N d z + rw [hr] + exact Submodule.zero_mem _ + · have hxi := oldGenerator_mem_orderPiece k n (.inl i) + have hxj := oldGenerator_mem_orderPiece k n (.inr j) + have hc := commutator_mem_orderPiece_pred k hxi hxj + have hc' : oldGenerator k n (.inr j) * oldGenerator k n (.inl i) - + oldGenerator k n (.inl i) * oldGenerator k n (.inr j) ∈ + orderPiece k (n + 1) 0 := by + simpa [Stafford.commutator] using (show + -(Stafford.commutator (oldGenerator k n (.inl i)) + (oldGenerator k n (.inr j))) ∈ orderPiece k (n + 1) 0 from + (orderPiece k (n + 1) 0).neg_mem hc) + rw [rightMul_commutator_apply] + simpa [tangentialDegree] using + (rightMul_lower_of_orderPiece k n N d hd _ hc' hz) + · have hxi := oldGenerator_mem_orderPiece k n (.inr i) + have hxj := oldGenerator_mem_orderPiece k n (.inl j) + have hc := commutator_mem_orderPiece_pred k hxi hxj + have hc' : oldGenerator k n (.inl j) * oldGenerator k n (.inr i) - + oldGenerator k n (.inr i) * oldGenerator k n (.inl j) ∈ + orderPiece k (n + 1) 0 := by + simpa [Stafford.commutator] using (show + -(Stafford.commutator (oldGenerator k n (.inr i)) + (oldGenerator k n (.inl j))) ∈ orderPiece k (n + 1) 0 from + (orderPiece k (n + 1) 0).neg_mem hc) + rw [rightMul_commutator_apply] + simpa [tangentialDegree] using + (rightMul_lower_of_orderPiece k n N d hd _ hc' hz) + · have hxi := oldGenerator_mem_orderPiece k n (.inr i) + have hxj := oldGenerator_mem_orderPiece k n (.inr j) + have hc := commutator_mem_orderPiece_pred k hxi hxj + rw [rightMul_commutator_apply] + have hc' := (orderPiece k (n + 1) 1).neg_mem hc + have hc'' : oldGenerator k n (.inr j) * oldGenerator k n (.inr i) - + oldGenerator k n (.inr i) * oldGenerator k n (.inr j) ∈ + orderPiece k (n + 1) 1 := by + convert hc' using 1 <;> simp [Stafford.commutator] + convert (rightMul_lower_of_orderPiece k n N d hd _ hc'' hz) using 1 <;> + norm_num [tangentialDegree] <;> ring + +end +end Stafford38.Characteristic.CanonicalTangentialPageOperators diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialRingEquivalence.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialRingEquivalence.lean new file mode 100644 index 0000000000..11a741b09f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialRingEquivalence.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness + +namespace Stafford38.Characteristic.CanonicalTangentialRingEquivalence + +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +open Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness +open Stafford38.Characteristic.NormalSymbolPolynomial +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable {k : Type*} [Field k] + +/-- The old rank-`n` phase variable, regarded as a rank-`n+1` variable which +is neither the new momentum nor the new coordinate. -/ +def oldTangentialVar (n : ℕ) (i : Fin n ⊕ Fin n) : TangentialVar n := + ⟨⟨oldIndex i, by + cases i with + | inl i => simp [oldIndex] + | inr i => simp [oldIndex]⟩, + by + cases i with + | inl i => simp [oldIndex] + | inr i => simp [oldIndex]⟩ + +private theorem oldTangentialVar_injective (n : ℕ) : + Function.Injective (oldTangentialVar n) := by + intro i j h + apply Stafford38.WeylPBW.oldIndex_injective + exact congrArg (fun v : TangentialVar n => v.1.1) h + +private theorem oldTangentialVar_surjective (n : ℕ) : + Function.Surjective (oldTangentialVar n) := by + intro v + rcases v with ⟨⟨w, hnormal⟩, hcoordinate⟩ + rcases w with i | i + · rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨j, rfl⟩ + · exact False.elim (hcoordinate (by rfl)) + · exact ⟨Sum.inl j, rfl⟩ + · rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨j, rfl⟩ + · exact False.elim (hnormal (by rfl)) + · exact ⟨Sum.inr j, rfl⟩ + +/-- The exact variable dictionary: the two retained subtype exclusions are +precisely the image of `oldIndex`. -/ +def oldTangentialVarEquiv (n : ℕ) : + (Fin n ⊕ Fin n) ≃ TangentialVar n := + Equiv.ofBijective (oldTangentialVar n) + ⟨oldTangentialVar_injective n, oldTangentialVar_surjective n⟩ + +@[simp] theorem oldTangentialVarEquiv_apply (n : ℕ) (i : Fin n ⊕ Fin n) : + (oldTangentialVarEquiv n i).1.1 = oldIndex i := + rfl + +/-- Rename old phase variables into the coefficient ring which omits both +new variables. -/ +def oldSymbolTangentialAlgEquiv (n : ℕ) : + MvPolynomial (Fin n ⊕ Fin n) k ≃ₐ[k] tangentialCoeffRing (k := k) n := + MvPolynomial.renameEquiv k (oldTangentialVarEquiv n) + +@[simp] theorem oldSymbolTangentialAlgEquiv_X (n : ℕ) + (i : Fin n ⊕ Fin n) : + oldSymbolTangentialAlgEquiv (k := k) n (MvPolynomial.X i) = + MvPolynomial.X (oldTangentialVarEquiv n i) := by + simp [oldSymbolTangentialAlgEquiv] + +/-- Under the full coefficient-action homomorphism, the renamed variable is +the actual ambient symbol indexed by `oldIndex`. -/ +theorem tangentialCoeffActionHom_oldSymbol_X (n : ℕ) + (i : Fin n ⊕ Fin n) : + ((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) + (oldSymbolTangentialAlgEquiv (k := k) n (MvPolynomial.X i)) = + (MvPolynomial.X (oldIndex i) : SymbolRing k (n + 1)) := by + simp [oldSymbolTangentialAlgEquiv, tangentialPolynomialActionHom, + normalCoeffTangentialAlgEquiv, tangentialVariableEquiv, + normalPolynomialActionHom, normalSymbolAlgEquiv, normalVariableEquiv, + oldTangentialVarEquiv_apply] + +/-- Consequently the named tangential coefficient module acts on every +symbol module by the same old-generator symbol used by the canonical total +polynomial action. -/ +theorem tangentialCoeffModule_oldSymbol_X_action + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] + (i : Fin n ⊕ Fin n) (z : E) : + @SMul.smul (tangentialCoeffRing (k := k) n) E + (tangentialCoeffModule (k := k) n E).toSMul + (oldSymbolTangentialAlgEquiv (k := k) n (MvPolynomial.X i)) z = + (MvPolynomial.X (oldIndex i) : SymbolRing k (n + 1)) • z := by + change ((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) + (oldSymbolTangentialAlgEquiv (k := k) n (MvPolynomial.X i)) • z = _ + rw [tangentialCoeffActionHom_oldSymbol_X] + + +end +end Stafford38.Characteristic.CanonicalTangentialRingEquivalence diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSuccessors.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSuccessors.lean new file mode 100644 index 0000000000..db4eefa07b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSuccessors.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialTotalAction +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermSuccessorNaturality + +/-! +# Successor pages over the tangential symbol ring + +The actual successor maps are tangential-linear. Their already proved +injectivity, surjectivity and exactness therefore give kernel and cokernel +equivalences over that ring, not just over the ground field. +-/ + +namespace Stafford38.Characteristic.CanonicalTangentialTotalAction + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +variable (k : Type*) [Field k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + +attribute [local instance] sourceModule targetModule + +theorem sourceSucc_intertwines_polynomials (r : ℕ) + (P : MvPolynomial (Fin n ⊕ Fin n) k) : + (complex k n N d hd).sourceTotalSuccMap r ∘ₗ sourceAction k n N d hd (r + 1) P = + sourceAction k n N d hd r P ∘ₗ (complex k n N d hd).sourceTotalSuccMap r := + commutingPolynomialAction_intertwines _ _ _ _ _ + (fun i => (generator k n N d hd i).sourceTotalSuccMap_naturality r) P + +theorem targetSucc_intertwines_polynomials (r : ℕ) + (P : MvPolynomial (Fin n ⊕ Fin n) k) : + (complex k n N d hd).targetTotalSuccMap r ∘ₗ targetAction k n N d hd r P = + targetAction k n N d hd (r + 1) P ∘ₗ (complex k n N d hd).targetTotalSuccMap r := + commutingPolynomialAction_intertwines _ _ _ _ _ + (fun i => (generator k n N d hd i).targetTotalSuccMap_naturality r) P + +def tangentialSourceSucc (r : ℕ) : + (complex k n N d hd).SourceTotal (r + 1) →ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + (complex k n N d hd).SourceTotal r where + toFun := (complex k n N d hd).sourceTotalSuccMap r + map_add' := map_add _ + map_smul' P z := congrArg (fun f => f z) + (sourceSucc_intertwines_polynomials k n N d hd r P) + +def tangentialTargetSucc (r : ℕ) : + (complex k n N d hd).TargetTotal r →ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + (complex k n N d hd).TargetTotal (r + 1) where + toFun := (complex k n N d hd).targetTotalSuccMap r + map_add' := map_add _ + map_smul' P z := congrArg (fun f => f z) + (targetSucc_intertwines_polynomials k n N d hd r P) + +theorem tangentialSourceSucc_injective (r : ℕ) : + Function.Injective (tangentialSourceSucc k n N d hd r) := + (complex k n N d hd).totalSourceSuccMap_injective r + +theorem tangentialSourceSucc_range (r : ℕ) : + (tangentialSourceSucc k n N d hd r).range = + (tangentialDrop k n N d hd r).ker := by + ext z + exact SetLike.ext_iff.mp ((complex k n N d hd).range_totalSourceSuccMap r) z + +theorem tangentialTargetSucc_surjective (r : ℕ) : + Function.Surjective (tangentialTargetSucc k n N d hd r) := + (DirectSum.lmap_surjective _).mpr ((complex k n N d hd).targetSuccMap_surjective r) + +theorem tangentialTargetSucc_ker (r : ℕ) : + (tangentialTargetSucc k n N d hd r).ker = + (tangentialDrop k n N d hd r).range := by + ext z + exact SetLike.ext_iff.mp ((complex k n N d hd).ker_totalTargetSuccMap r) z + +def tangentialSourceSuccEquiv (r : ℕ) : + (complex k n N d hd).SourceTotal (r + 1) ≃ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + (tangentialDrop k n N d hd r).ker := + LinearEquiv.ofInjective (tangentialSourceSucc k n N d hd r) + (tangentialSourceSucc_injective k n N d hd r) ≪≫ₗ + LinearEquiv.ofEq _ _ (tangentialSourceSucc_range k n N d hd r) + +def tangentialTargetSuccEquiv (r : ℕ) : + (complex k n N d hd).TargetTotal (r + 1) ≃ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + ((complex k n N d hd).TargetTotal r ⧸ (tangentialDrop k n N d hd r).range) := + ((Submodule.quotEquivOfEq _ _ (tangentialTargetSucc_ker k n N d hd r).symm) ≪≫ₗ + (tangentialTargetSucc k n N d hd r).quotKerEquivOfSurjective + (tangentialTargetSucc_surjective k n N d hd r)).symm + + +end +end Stafford38.Characteristic.CanonicalTangentialTotalAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSymbolFiniteness.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSymbolFiniteness.lean new file mode 100644 index 0000000000..0300eaf943 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialSymbolFiniteness.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalSymbolFiniteness + +namespace Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.Characteristic.NormalSymbolPolynomial +open Stafford38.Characteristic.CanonicalNormalSymbolFiniteness +open Stafford38.Characteristic.MonicAnnihilatorFinite +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBWMonicBridge + +noncomputable section +variable {k : Type*} [Field k] + +abbrev NormalVar (n : ℕ) := + {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))} +abbrev TangentialVar (n : ℕ) := + {v : NormalVar n // v ≠ ⟨Sum.inl (0 : Fin (n + 1)), by simp⟩} + +abbrev tangentialCoeffRing (n : ℕ) := + MvPolynomial (TangentialVar n) k + +def tangentialVariableEquiv (n : ℕ) : + Option (TangentialVar n) ≃ NormalVar n := + Equiv.optionSubtypeNe + (⟨Sum.inl (0 : Fin (n + 1)), by simp⟩ : NormalVar n) + +def normalCoeffTangentialAlgEquiv (n : ℕ) : + normalCoeffRing (k := k) n ≃ₐ[k] + Polynomial (tangentialCoeffRing (k := k) n) := + (MvPolynomial.renameEquiv k (tangentialVariableEquiv n).symm).trans + (MvPolynomial.optionEquivLeft k (TangentialVar n)) + +def tangentialPolynomialActionHom (n : ℕ) : + Polynomial (tangentialCoeffRing (k := k) n) →+* + SymbolRing k (n + 1) := + (normalPolynomialActionHom (k := k) n).comp + ((Polynomial.C : normalCoeffRing (k := k) n →+* + Polynomial (normalCoeffRing (k := k) n)).comp + (normalCoeffTangentialAlgEquiv (k := k) n).symm.toRingHom) + +@[instance_reducible] def tangentialPolynomialModule + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (Polynomial (tangentialCoeffRing (k := k) n)) E := + Module.compHom E (tangentialPolynomialActionHom (k := k) n) + +@[instance_reducible] def tangentialCoeffModule + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (tangentialCoeffRing (k := k) n) E := + Module.compHom E + ((tangentialPolynomialActionHom (k := k) n).comp Polynomial.C) + +local instance tangentialPolynomialModuleInstance + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (Polynomial (tangentialCoeffRing (k := k) n)) E := + tangentialPolynomialModule (k := k) n E + +local instance tangentialCoeffModuleInstance + (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + Module (tangentialCoeffRing (k := k) n) E := + tangentialCoeffModule (k := k) n E + +/-- Multiplication by the polynomial variable after splitting off `x₀`. +The lemma below identifies this transported operator with the actual `x₀` +symbol action. -/ +def tangentialCoordinateMap (n : ℕ) (E : Type*) [AddCommGroup E] + [Module (SymbolRing k (n + 1)) E] : + E →ₗ[tangentialCoeffRing (k := k) n] E := by + refine + { toFun := fun z => (Polynomial.X : + Polynomial (tangentialCoeffRing (k := k) n)) • z + map_add' := smul_add _ + map_smul' := ?_ } + intro r z + change (Polynomial.X : Polynomial (tangentialCoeffRing (k := k) n)) • + (Polynomial.C r • z) = + Polynomial.C r • + ((Polynomial.X : Polynomial (tangentialCoeffRing (k := k) n)) • z) + rw [← mul_smul, ← mul_smul, mul_comm] + +theorem tangentialCoordinateMap_apply (n : ℕ) (E : Type*) + [AddCommGroup E] [Module (SymbolRing k (n + 1)) E] (z : E) : + tangentialCoordinateMap (k := k) n E z = + (MvPolynomial.X (Sum.inl (0 : Fin (n + 1))) : + SymbolRing k (n + 1)) • z := by + change (normalSymbolAlgEquiv (k := k) n).symm + (Polynomial.C ((normalCoeffTangentialAlgEquiv (k := k) n).symm + Polynomial.X)) • z = _ + congr 1 + apply (normalSymbolAlgEquiv (k := k) n).injective + rw [(normalSymbolAlgEquiv (k := k) n).apply_symm_apply] + have hx : (normalCoeffTangentialAlgEquiv (k := k) n).symm + Polynomial.X = MvPolynomial.X + (⟨Sum.inl (0 : Fin (n + 1)), by simp⟩ : NormalVar n) := by + apply (normalCoeffTangentialAlgEquiv (k := k) n).injective + rw [(normalCoeffTangentialAlgEquiv (k := k) n).apply_symm_apply] + simp [normalCoeffTangentialAlgEquiv, tangentialVariableEquiv] + rw [hx] + exact (normalSymbolAlgEquiv_otherVariable (k := k) n + (Sum.inl (0 : Fin (n + 1))) (by simp)).symm + +/-- Kernel and cokernel of the actual distinguished coordinate symbol on the +canonical associated graded quotient are finite over the ring omitting both +that coordinate and the normal covariable. -/ +theorem canonical_orderAssociatedGradedModule_finite_tangential_coordinate + {n N : ℕ} {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + let E := OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N) + @Module.Finite (tangentialCoeffRing (k := k) n) + (LinearMap.ker (tangentialCoordinateMap (k := k) n E)) _ _ + (inferInstance) ∧ + @Module.Finite (tangentialCoeffRing (k := k) n) + (E ⧸ LinearMap.range (tangentialCoordinateMap (k := k) n E)) _ _ + (inferInstance) := by + let T := tangentialCoeffRing (k := k) n + let R := normalCoeffRing (k := k) n + let E := OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N) + let e := normalCoeffTangentialAlgEquiv (k := k) n + letI : Module R E := normalCoeffModule (k := k) n E + haveI hR : Module.Finite R E := + canonical_orderAssociatedGradedModule_finite_normalCoeffRing hd + letI : Module (Polynomial T) E := tangentialPolynomialModule (k := k) n E + letI : Module T E := tangentialCoeffModule (k := k) n E + letI : IsScalarTower T (Polynomial T) E := + ⟨by + intro r p z + rw [Polynomial.smul_eq_C_mul, mul_smul] + change Polynomial.C r • (p • z) = Polynomial.C r • (p • z) + rfl⟩ + have hscalar (r : R) (z : E) : e r • z = r • z := by + change (normalSymbolAlgEquiv (k := k) n).symm + (Polynomial.C (e.symm (e r))) • z = + (normalSymbolAlgEquiv (k := k) n).symm (Polynomial.C r) • z + rw [e.symm_apply_apply] + haveI : Module.Finite (Polynomial T) E := by + rcases hR with ⟨⟨s, hs⟩⟩ + refine ⟨⟨s, top_unique ?_⟩⟩ + intro z hz + have hzold : z ∈ Submodule.span R (s : Set E) := by + rw [hs] + exact Submodule.mem_top + exact Submodule.span_induction + (p := fun z _ => z ∈ Submodule.span (Polynomial T) (s : Set E)) + (fun x hx => Submodule.subset_span hx) + (Submodule.zero_mem _) + (fun _ _ _ _ hx hy => Submodule.add_mem _ hx hy) + (fun r x _ hx => by + rw [← hscalar r x] + exact Submodule.smul_mem _ (e r) hx) + hzold + let f := LinearMap.lsmul (Polynomial T) E Polynomial.X + have hf : tangentialCoordinateMap (k := k) n E = + f.restrictScalars T := by + ext z + rfl + dsimp only + rw [hf] + exact finite_kernel_and_cokernel_variable (R := T) (E := E) + + +end +end Stafford38.Characteristic.CanonicalTangentialSymbolFiniteness diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialTotalAction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialTotalAction.lean new file mode 100644 index 0000000000..606c3c28a8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTangentialTotalAction.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialPageOperators +import LeanPool.Stafford38.Stafford38.Characteristic.CommutingPolynomialAction + +/-! +# Tangential symbol action on the canonical total pages + +The commuting polynomial action is constructed from the actual right Weyl +generators. Their commutators have lower order and hence vanish on the pages. +-/ + +namespace Stafford38.Characteristic.CanonicalTangentialTotalAction + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.Characteristic.CanonicalTangentialPageOperators +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +variable (k : Type*) [Field k] [Algebra ℚ k] +variable (n N : ℕ) (d : PresentedWeyl k (n + 1)) +variable (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + +abbrev complex := canonicalFilteredTwoTerm k n N d hd + +def generator (i : Fin n ⊕ Fin n) : + (complex k n N d hd).PageOperator (tangentialDegree i : ℤ) := + match i with + | .inl j => tangential_coordinate_pageOperator k n N d hd j + | .inr j => tangential_momentum_pageOperator k n N d hd j + +theorem generator_commutator_lowers (i j : Fin n ⊕ Fin n) + (p : ℤ) (z : CanonicalQuotient k n N d) + (hz : z ∈ (complex k n N d hd).G p) : + (generator k n N d hd i).g ((generator k n N d hd j).g z) - + (generator k n N d hd j).g ((generator k n N d hd i).g z) ∈ + (complex k n N d hd).G + (p - (tangentialDegree i : ℤ) - (tangentialDegree j : ℤ) + 1) := by + have h := tangential_commutator_lower k n N d hd i j p z hz + cases i <;> cases j <;> + simpa [generator, tangential_coordinate_pageOperator, + tangential_momentum_pageOperator, tangentialPageOperator, + tangentialDegree, show p - 1 - 1 + 1 = p - 2 + 1 by omega] using h + +def sourceGenerator (r : ℕ) (i : Fin n ⊕ Fin n) : + Module.End k ((complex k n N d hd).SourceTotal r) := + (generator k n N d hd i).sourceTotalMap r + +def targetGenerator (r : ℕ) (i : Fin n ⊕ Fin n) : + Module.End k ((complex k n N d hd).TargetTotal r) := + (generator k n N d hd i).targetTotalMap r + +theorem sourceGenerator_commute (r : ℕ) (i j : Fin n ⊕ Fin n) : + Commute (sourceGenerator k n N d hd r i) (sourceGenerator k n N d hd r j) := + (generator k n N d hd i).sourceTotalMap_commute_of_commutator_lowers + (generator k n N d hd j) (generator_commutator_lowers k n N d hd i j) r + +theorem targetGenerator_commute (r : ℕ) (i j : Fin n ⊕ Fin n) : + Commute (targetGenerator k n N d hd r i) (targetGenerator k n N d hd r j) := + (generator k n N d hd i).targetTotalMap_commute_of_commutator_lowers + (generator k n N d hd j) (generator_commutator_lowers k n N d hd i j) r + +def sourceAction (r : ℕ) : + MvPolynomial (Fin n ⊕ Fin n) k →ₐ[k] + Module.End k ((complex k n N d hd).SourceTotal r) := + commutingPolynomialAction (sourceGenerator k n N d hd r) + (sourceGenerator_commute k n N d hd r) + +def targetAction (r : ℕ) : + MvPolynomial (Fin n ⊕ Fin n) k →ₐ[k] + Module.End k ((complex k n N d hd).TargetTotal r) := + commutingPolynomialAction (targetGenerator k n N d hd r) + (targetGenerator_commute k n N d hd r) + +theorem totalDrop_intertwines_polynomials (r : ℕ) + (P : MvPolynomial (Fin n ⊕ Fin n) k) : + (complex k n N d hd).totalDrop r ∘ₗ sourceAction k n N d hd r P = + targetAction k n N d hd r P ∘ₗ (complex k n N d hd).totalDrop r := + commutingPolynomialAction_intertwines _ _ _ _ _ + (fun i => (generator k n N d hd i).totalDrop_intertwines r) P + +@[instance_reducible] def sourceModule (r : ℕ) : + Module (MvPolynomial (Fin n ⊕ Fin n) k) + ((complex k n N d hd).SourceTotal r) := + Module.compHom _ (sourceAction k n N d hd r).toRingHom + +@[instance_reducible] def targetModule (r : ℕ) : + Module (MvPolynomial (Fin n ⊕ Fin n) k) + ((complex k n N d hd).TargetTotal r) := + Module.compHom _ (targetAction k n N d hd r).toRingHom + +attribute [local instance] sourceModule targetModule + +/-- The concrete page differential is linear over the tangential symbol ring. -/ +def tangentialDrop (r : ℕ) : + (complex k n N d hd).SourceTotal r →ₗ[MvPolynomial (Fin n ⊕ Fin n) k] + (complex k n N d hd).TargetTotal r where + toFun := (complex k n N d hd).totalDrop r + map_add' := map_add _ + map_smul' P z := by + exact congrArg (fun f => f z) + (totalDrop_intertwines_polynomials k n N d hd r P) + +@[simp] theorem tangentialDrop_apply (r : ℕ) + (z : (complex k n N d hd).SourceTotal r) : + tangentialDrop k n N d hd r z = (complex k n N d hd).totalDrop r z := rfl + + +end +end Stafford38.Characteristic.CanonicalTangentialTotalAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedActionCompatibility.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedActionCompatibility.lean new file mode 100644 index 0000000000..d2098a6832 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedActionCompatibility.lean @@ -0,0 +1,395 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTotalGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialTotalAction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalTangentialRingEquivalence + +namespace Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.Characteristic.CanonicalFilteredGradedBridge +open Stafford38.Characteristic.CanonicalTotalGradedBridge +open Stafford38.Characteristic.CanonicalTangentialPageOperators +open Stafford38.Characteristic.CanonicalTangentialTotalAction +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylPBW +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylQuotientTransport +open Stafford38.WeylSymplectic +open Stafford38.CanonicalAxisAvoidanceConsumer + +noncomputable section + +universe u +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CI (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +private abbrev K (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + canonicalFilteredTwoTerm k n N d hd + +def oldGeneratorOrderPiece (n : ℕ) (i : Fin n ⊕ Fin n) : + orderPiece k (n + 1) (tangentialDegree i) := by + refine ⟨oldGenerator k n i, ?_⟩ + cases i with + | inl i => + rw [oldGenerator, orderPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X'] at hm + split at hm + · subst m; simp [oldIndex, monomialWeight, orderWeight, fibreWeight, + tangentialDegree] + · contradiction + | inr i => + rw [oldGenerator, orderPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X'] at hm + split at hm + · subst m; simp [oldIndex, monomialWeight, orderWeight, fibreWeight, + tangentialDegree] + · contradiction + +theorem principal_oldGenerator (n : ℕ) (i : Fin n ⊕ Fin n) : + (principalComponentOnPiece k (@orderWeight (n + 1)) (tangentialDegree i) + (oldGeneratorOrderPiece k n i) : SymbolRing k (n + 1)) = + MvPolynomial.X (oldIndex i) := by + cases i + · change MvPolynomial.weightedHomogeneousComponent orderWeight 0 + (presentedNormalFormLinearEquiv k (n + 1) + (Stafford.freeWeylGenerator (standardForm k (n + 1)) (.inl _))) = _ + rw [presentedNormalFormLinearEquiv_generator] + change MvPolynomial.weightedHomogeneousComponent orderWeight 0 + (MvPolynomial.monomial (Finsupp.single (Sum.inl _) 1) 1) = _ + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, orderWeight, fibreWeight, oldIndex] + rw [MvPolynomial.monomial_eq] + simp + + · change MvPolynomial.weightedHomogeneousComponent orderWeight 1 + (presentedNormalFormLinearEquiv k (n + 1) + (Stafford.freeWeylGenerator (standardForm k (n + 1)) (.inr _))) = _ + rw [presentedNormalFormLinearEquiv_generator] + change MvPolynomial.weightedHomogeneousComponent orderWeight 1 + (MvPolynomial.monomial (Finsupp.single (Sum.inr _) 1) 1) = _ + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, orderWeight, fibreWeight, oldIndex] + rw [MvPolynomial.monomial_eq] + simp + +def sourceRepresentative (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (a : orderPiece k (n + 1) m) : + (K k n N d hd).SourcePage 0 p := + Submodule.Quotient.mk ⟨Submodule.Quotient.mk (a : PresentedWeyl k (n + 1)), by + rw [h, zeroPage_source_cycles_eq_orderPiece k n N m d hd] + exact ⟨a, a.property, rfl⟩⟩ + +def targetRepresentative (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (a : orderPiece k (n + 1) m) : + (K k n N d hd).TargetPage 0 p := + Submodule.Quotient.mk ⟨Submodule.Quotient.mk (a : PresentedWeyl k (n + 1)), by + rw [h, G_at_neg k n N m d hd] + exact ⟨a, a.property, rfl⟩⟩ + +private theorem sourceRepresentative_cast (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p q : ℤ} (m : ℕ) (hp : p = -(m : ℤ)) (hq : q = -(m : ℤ)) + (h : p = q) (a : orderPiece k (n + 1) m) : + LinearEquiv.cast (R := k) (M := fun p => (K k n N d hd).SourcePage 0 p) h + (sourceRepresentative k n N d hd p m hp a) = + sourceRepresentative k n N d hd q m hq a := by + cases h + rfl + +private theorem targetRepresentative_cast (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p q : ℤ} (m : ℕ) (hp : p = -(m : ℤ)) (hq : q = -(m : ℤ)) + (h : p = q) (a : orderPiece k (n + 1) m) : + LinearEquiv.cast (R := k) (M := fun p => (K k n N d hd).TargetPage 0 p) h + (targetRepresentative k n N d hd p m hp a) = + targetRepresentative k n N d hd q m hq a := by + cases h + rfl + +private theorem sourceRepresentative_lof_eq (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p q : ℤ} (m : ℕ) (hp : p = -(m : ℤ)) (hq : q = -(m : ℤ)) + (a : orderPiece k (n + 1) m) : + DirectSum.lof k ℤ _ p (sourceRepresentative k n N d hd p m hp a) = + DirectSum.lof k ℤ _ q (sourceRepresentative k n N d hd q m hq a) := by + have h : p = q := hp.trans hq.symm + cases h + rfl + +private theorem targetRepresentative_lof_eq (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p q : ℤ} (m : ℕ) (hp : p = -(m : ℤ)) (hq : q = -(m : ℤ)) + (a : orderPiece k (n + 1) m) : + DirectSum.lof k ℤ _ p (targetRepresentative k n N d hd p m hp a) = + DirectSum.lof k ℤ _ q (targetRepresentative k n N d hd q m hq a) := by + have h : p = q := hp.trans hq.symm + cases h + rfl + +theorem sourceEquiv_representative (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (a : orderPiece k (n + 1) m) : + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (DirectSum.lof k ℤ (fun p => (K k n N d hd).SourcePage 0 p) p + (sourceRepresentative k n N d hd p m h a)) = + orderAssociatedGradedOf k (CI k n N d) m + (orderPieceToQuotientGraded k (CI k n N d) m a) := by + rw [sourceRepresentative_lof_eq k n N d hd m h (negIndex_eq m) a] + have H := sourceTotal0LinearEquiv_lof_negIndex k n N m d hd + (sourceRepresentative k n N d hd (negIndex m) m (negIndex_eq m) a) + rw [H, LinearEquiv.trans_apply, sourceRepresentative_cast] + congr 1 + simp [zeroPageSourceLinearEquivOrderGradedPiece, sourceRepresentative, + orderPieceToQuotientGraded, orderPieceToQuotientPiece] + +theorem targetEquiv_representative (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (a : orderPiece k (n + 1) m) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (DirectSum.lof k ℤ (fun p => (K k n N d hd).TargetPage 0 p) p + (targetRepresentative k n N d hd p m h a)) = + orderAssociatedGradedOf k (CI k n N d) m + (orderPieceToQuotientGraded k (CI k n N d) m a) := by + rw [targetRepresentative_lof_eq k n N d hd m h (negIndex_eq m) a] + have H := targetTotal0LinearEquiv_lof_negIndex k n N m d hd + (targetRepresentative k n N d hd (negIndex m) m (negIndex_eq m) a) + rw [H, LinearEquiv.trans_apply, targetRepresentative_cast] + congr 1 + simp [zeroPageTargetLinearEquivOrderGradedPiece, targetRepresentative, + orderPieceToQuotientGraded, orderPieceToQuotientPiece] +theorem sourceRepresentative_surjective (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) : + Function.Surjective (sourceRepresentative k n N d hd p m h) := by + subst p + intro y + induction y using Submodule.Quotient.induction_on with + | _ y => + have hy := (le_of_eq (zeroPage_source_cycles_eq_orderPiece k n N m d hd)) y.property + obtain ⟨a, ha, hay⟩ := hy + refine ⟨⟨a, ha⟩, ?_⟩ + apply congrArg Submodule.Quotient.mk + apply Subtype.ext + exact hay + +theorem targetRepresentative_surjective (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) : + Function.Surjective (targetRepresentative k n N d hd p m h) := by + subst p + intro y + induction y using Submodule.Quotient.induction_on with + | _ y => + have hy := (le_of_eq (G_at_neg k n N m d hd)) y.property + obtain ⟨a, ha, hay⟩ := hy + refine ⟨⟨a, ha⟩, ?_⟩ + apply congrArg Submodule.Quotient.mk + apply Subtype.ext + exact hay + +theorem sourceRepresentative_map (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (e : ℕ) (a : orderPiece k (n + 1) e) + (P : (K k n N d hd).PageOperator (e : ℤ)) + (hP : P.g = rightMulLinearMap k (CI k n N d) a) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (z : orderPiece k (n + 1) m) : + P.sourceMap 0 p (sourceRepresentative k n N d hd p m h z) = + sourceRepresentative k n N d hd (p - e) (m + e) (by omega) + ⟨(z : PresentedWeyl k (n + 1)) * a, + mul_mem_orderPiece k z.property a.property⟩ := by + rw [sourceRepresentative, P.sourceMap_mk] + apply congrArg Submodule.Quotient.mk + apply Subtype.ext + change P.g (Submodule.Quotient.mk (z : PresentedWeyl k (n + 1))) = _ + rw [hP, rightMulLinearMap_mk] + +theorem targetRepresentative_map (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (e : ℕ) (a : orderPiece k (n + 1) e) + (P : (K k n N d hd).PageOperator (e : ℤ)) + (hP : P.g = rightMulLinearMap k (CI k n N d) a) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (z : orderPiece k (n + 1) m) : + P.targetMap 0 p (targetRepresentative k n N d hd p m h z) = + targetRepresentative k n N d hd (p - e) (m + e) (by omega) + ⟨(z : PresentedWeyl k (n + 1)) * a, + mul_mem_orderPiece k z.property a.property⟩ := by + rw [targetRepresentative, P.targetMap_mk] + apply congrArg Submodule.Quotient.mk + apply Subtype.ext + change P.g (Submodule.Quotient.mk (z : PresentedWeyl k (n + 1))) = _ + rw [hP, rightMulLinearMap_mk] + +theorem sourceEquiv_intertwines_rightMul (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (e : ℕ) (a : orderPiece k (n + 1) e) + (P : (K k n N d hd).PageOperator (e : ℤ)) + (hP : P.g = rightMulLinearMap k (CI k n N d) a) + (z : (K k n N d hd).SourceTotal 0) : + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd (P.sourceTotalMap 0 z) = + (principalComponentOnPiece k (@orderWeight (n + 1)) e a : SymbolRing k (n + 1)) • + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + induction z using DirectSum.induction_on with + | zero => simp + | of p y => + by_cases hp : 0 < p + · haveI := zeroPage_source_subsingleton_of_pos k n N p d hd hp + simp [Subsingleton.elim y 0] + · let m := (-p).toNat + have hm : p = -(m : ℤ) := by dsimp [m]; omega + obtain ⟨z, rfl⟩ := sourceRepresentative_surjective k n N d hd p m hm y + rw [show DirectSum.of ((K k n N d hd).SourcePage 0) p = + (DirectSum.lof k ℤ (fun p => (K k n N d hd).SourcePage 0 p) p).toAddMonoidHom from rfl] + simp only [LinearMap.toAddMonoidHom_coe] + change sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (P.sourceTotalMap 0 (DirectSum.lof k ℤ _ p + (sourceRepresentative k n N d hd p m hm z))) = _ + rw [P.sourceTotalMap_lof, + sourceRepresentative_map k n N d hd e a P hP, + sourceEquiv_representative, sourceEquiv_representative, + smul_orderAssociatedGradedOf_mk_eq_of_mul] + | add x y hx hy => simpa [smul_add] using congrArg₂ (· + ·) hx hy + +theorem targetEquiv_intertwines_rightMul (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (e : ℕ) (a : orderPiece k (n + 1) e) + (P : (K k n N d hd).PageOperator (e : ℤ)) + (hP : P.g = rightMulLinearMap k (CI k n N d) a) + (z : (K k n N d hd).TargetTotal 0) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd (P.targetTotalMap 0 z) = + (principalComponentOnPiece k (@orderWeight (n + 1)) e a : SymbolRing k (n + 1)) • + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + induction z using DirectSum.induction_on with + | zero => simp + | of p y => + by_cases hp : 0 < p + · haveI := zeroPage_target_subsingleton_of_pos k n N p d hd hp + simp [Subsingleton.elim y 0] + · let m := (-p).toNat + have hm : p = -(m : ℤ) := by dsimp [m]; omega + obtain ⟨z, rfl⟩ := targetRepresentative_surjective k n N d hd p m hm y + rw [show DirectSum.of ((K k n N d hd).TargetPage 0) p = + (DirectSum.lof k ℤ (fun p => (K k n N d hd).TargetPage 0 p) p).toAddMonoidHom from rfl] + simp only [LinearMap.toAddMonoidHom_coe] + change targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (P.targetTotalMap 0 (DirectSum.lof k ℤ _ p + (targetRepresentative k n N d hd p m hm z))) = _ + rw [P.targetTotalMap_lof, + targetRepresentative_map k n N d hd e a P hP, + targetEquiv_representative, targetEquiv_representative, + smul_orderAssociatedGradedOf_mk_eq_of_mul] + | add x y hx hy => simpa [smul_add] using congrArg₂ (· + ·) hx hy + +theorem sourceEquiv_intertwines_generator (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (i : Fin n ⊕ Fin n) (z : (K k n N d hd).SourceTotal 0) : + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (sourceGenerator k n N d hd 0 i z) = + (MvPolynomial.X (oldIndex i) : SymbolRing k (n + 1)) • + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + have h := sourceEquiv_intertwines_rightMul k n N d hd (tangentialDegree i) + (oldGeneratorOrderPiece k n i) (generator k n N d hd i) (by cases i <;> rfl) z + rw [principal_oldGenerator] at h + exact h + +theorem targetEquiv_intertwines_generator (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (i : Fin n ⊕ Fin n) (z : (K k n N d hd).TargetTotal 0) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (targetGenerator k n N d hd 0 i z) = + (MvPolynomial.X (oldIndex i) : SymbolRing k (n + 1)) • + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + have h := targetEquiv_intertwines_rightMul k n N d hd (tangentialDegree i) + (oldGeneratorOrderPiece k n i) (generator k n N d hd i) (by cases i <;> rfl) z + rw [principal_oldGenerator] at h + exact h + +def coordinateOrderPiece (n : ℕ) : orderPiece k (n + 1) 0 := + ⟨presentedCoordinate k n, presentedCoordinate_mem_orderPiece_zero k n⟩ + +theorem principal_coordinate (n : ℕ) : + (principalComponentOnPiece k (@orderWeight (n + 1)) 0 + (coordinateOrderPiece k n) : SymbolRing k (n + 1)) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) := by + change MvPolynomial.weightedHomogeneousComponent orderWeight 0 + (presentedNormalFormLinearEquiv k (n + 1) + (Stafford.freeWeylGenerator (standardForm k (n + 1)) (.inl 0))) = _ + rw [presentedNormalFormLinearEquiv_generator] + change MvPolynomial.weightedHomogeneousComponent orderWeight 0 + (MvPolynomial.monomial (Finsupp.single (Sum.inl (0 : Fin (n + 1))) 1) 1) = _ + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, orderWeight, fibreWeight] + rw [MvPolynomial.monomial_eq] + simp + +theorem sourceRepresentative_drop (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (p : ℤ) (m : ℕ) (h : p = -(m : ℤ)) (z : orderPiece k (n + 1) m) : + (K k n N d hd).drop 0 p (sourceRepresentative k n N d hd p m h z) = + targetRepresentative k n N d hd (p + 0) (m + 0) (by omega) + ⟨(z : PresentedWeyl k (n + 1)) * presentedCoordinate k n, + mul_mem_orderPiece k z.property (presentedCoordinate_mem_orderPiece_zero k n)⟩ := by + rw [sourceRepresentative, (K k n N d hd).drop_mk] + apply congrArg Submodule.Quotient.mk + apply Subtype.ext + rfl + +theorem totalDrop_zero_intertwines_coordinate (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (z : (K k n N d hd).SourceTotal 0) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + ((K k n N d hd).totalDrop 0 z) = + (MvPolynomial.X (.inl (0 : Fin (n + 1))) : SymbolRing k (n + 1)) • + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd z := by + induction z using DirectSum.induction_on with + | zero => simp + | of p y => + by_cases hp : 0 < p + · haveI := zeroPage_source_subsingleton_of_pos k n N p d hd hp + simp [Subsingleton.elim y 0] + · let m := (-p).toNat + have hm : p = -(m : ℤ) := by dsimp [m]; omega + obtain ⟨z, rfl⟩ := sourceRepresentative_surjective k n N d hd p m hm y + rw [show DirectSum.of ((K k n N d hd).SourcePage 0) p = + (DirectSum.lof k ℤ (fun p => (K k n N d hd).SourcePage 0 p) p).toAddMonoidHom from rfl] + simp only [LinearMap.toAddMonoidHom_coe] + change targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + ((K k n N d hd).totalDrop 0 (DirectSum.lof k ℤ _ p + (sourceRepresentative k n N d hd p m hm z))) = _ + rw [(K k n N d hd).totalDrop_lof, + sourceRepresentative_drop] + trans orderAssociatedGradedOf k (CI k n N d) (m + 0) + (orderPieceToQuotientGraded k (CI k n N d) (m + 0) + ⟨(z : PresentedWeyl k (n + 1)) * presentedCoordinate k n, + mul_mem_orderPiece k z.property (presentedCoordinate_mem_orderPiece_zero k n)⟩) + · exact targetEquiv_representative k n N d hd (p + 0) (m + 0) (by omega) _ + · rw [sourceEquiv_representative, ← principal_coordinate k n, + smul_orderAssociatedGradedOf_mk_eq_of_mul] + rfl + | add x y hx hy => simpa [smul_add] using congrArg₂ (· + ·) hx hy + + +end +end Stafford38.Characteristic.CanonicalTotalGradedActionCompatibility diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedBridge.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedBridge.lean new file mode 100644 index 0000000000..d89665bbba --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalTotalGradedBridge.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalFilteredGradedBridge +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalPages + +namespace Stafford38.Characteristic.CanonicalTotalGradedBridge + +open Stafford38.Characteristic +open Stafford38.Characteristic.FilteredTwoTermPages +open Stafford38.Characteristic.CanonicalFilteredTwoTerm +open Stafford38.Characteristic.CanonicalFilteredGradedBridge +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +section ReindexNonpositive + +variable {A : ℤ → Type u} {B : ℕ → Type u} +variable [∀ p, AddCommMonoid (A p)] [∀ p, Module k (A p)] +variable [∀ m, AddCommMonoid (B m)] [∀ m, Module k (B m)] + +def negIndex : ℕ → ℤ + | 0 => 0 + | n + 1 => Int.negSucc n + +theorem negIndex_eq (m : ℕ) : negIndex m = -(m : ℤ) := by + cases m <;> simp [negIndex, Int.negSucc_eq] + +private noncomputable def nonpositiveDirectSumToNat + (e : ∀ m : ℕ, A (negIndex m) ≃ₗ[k] B m) : + DirectSum ℤ A →ₗ[k] DirectSum ℕ B := + DirectSum.toModule k ℤ (DirectSum ℕ B) (fun p => + match p with + | Int.ofNat 0 => (DirectSum.lof k ℕ B 0).comp (e 0).toLinearMap + | Int.ofNat (n + 1) => 0 + | Int.negSucc n => + (DirectSum.lof k ℕ B (n + 1)).comp (e (n + 1)).toLinearMap) + +private noncomputable def natDirectSumToNonpositive + (e : ∀ m : ℕ, A (negIndex m) ≃ₗ[k] B m) : + DirectSum ℕ B →ₗ[k] DirectSum ℤ A := + DirectSum.toModule k ℕ (DirectSum ℤ A) (fun m => + (DirectSum.lof k ℤ A (negIndex m)).comp (e m).symm.toLinearMap) + +@[simp] private theorem natDirectSumToNonpositive_lof + (e : ∀ m : ℕ, A (negIndex m) ≃ₗ[k] B m) (m : ℕ) (x : B m) : + natDirectSumToNonpositive k e (DirectSum.lof k ℕ B m x) = + DirectSum.lof k ℤ A (negIndex m) ((e m).symm x) := by + rw [natDirectSumToNonpositive, DirectSum.toModule_lof] + rfl + +private noncomputable def nonpositiveDirectSumLinearEquiv + (e : ∀ m : ℕ, A (negIndex m) ≃ₗ[k] B m) + (hpos : ∀ p, 0 < p → Subsingleton (A p)) : + DirectSum ℤ A ≃ₗ[k] DirectSum ℕ B := by + refine LinearEquiv.ofLinearMap (nonpositiveDirectSumToNat k e) + (natDirectSumToNonpositive k e) ?_ ?_ + · apply DirectSum.linearMap_ext k + intro m + apply LinearMap.ext + intro x + change nonpositiveDirectSumToNat k e + (natDirectSumToNonpositive k e (DirectSum.lof k ℕ B m x)) = + DirectSum.lof k ℕ B m x + rw [natDirectSumToNonpositive_lof] + cases m with + | zero => + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + change DirectSum.lof k ℕ B 0 (e 0 ((e 0).symm x)) = _ + rw [(e 0).apply_symm_apply] + | succ m => + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + change DirectSum.lof k ℕ B (m + 1) + (e (m + 1) ((e (m + 1)).symm x)) = _ + rw [(e (m + 1)).apply_symm_apply] + · apply DirectSum.linearMap_ext k + intro p + apply LinearMap.ext + intro x + change natDirectSumToNonpositive k e + (nonpositiveDirectSumToNat k e (DirectSum.lof k ℤ A p x)) = + DirectSum.lof k ℤ A p x + cases p with + | ofNat n => + cases n with + | zero => + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + change natDirectSumToNonpositive k e + (DirectSum.lof k ℕ B 0 (e 0 x)) = DirectSum.lof k ℤ A 0 x + rw [natDirectSumToNonpositive_lof] + congr 1 + exact (e 0).symm_apply_apply (show A (negIndex 0) from x) + | succ n => + haveI := hpos (Int.ofNat (n + 1)) (by simp) + simp [nonpositiveDirectSumToNat, Subsingleton.elim x 0] + | negSucc n => + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + change natDirectSumToNonpositive k e + (DirectSum.lof k ℕ B (n + 1) (e (n + 1) x)) = + DirectSum.lof k ℤ A (Int.negSucc n) x + rw [natDirectSumToNonpositive_lof] + congr 1 + exact (e (n + 1)).symm_apply_apply + (show A (negIndex (n + 1)) from x) + +@[simp] private theorem nonpositiveDirectSumLinearEquiv_lof + (e : ∀ m : ℕ, A (negIndex m) ≃ₗ[k] B m) + (hpos : ∀ p, 0 < p → Subsingleton (A p)) (m : ℕ) (x : A (negIndex m)) : + nonpositiveDirectSumLinearEquiv k e hpos + (DirectSum.lof k ℤ A (negIndex m) x) = + DirectSum.lof k ℕ B m (e m x) := by + cases m with + | zero => + change nonpositiveDirectSumToNat k e + (DirectSum.lof k ℤ A (negIndex 0) x) = _ + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + rfl + | succ m => + change nonpositiveDirectSumToNat k e + (DirectSum.lof k ℤ A (negIndex (m + 1)) x) = _ + rw [nonpositiveDirectSumToNat, DirectSum.toModule_lof] + rfl + +end ReindexNonpositive + +private abbrev CI (n N : ℕ) (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +private abbrev K (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + canonicalFilteredTwoTerm k n N d hd + +abbrev SourceTotal0 (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + (K k n N d hd).SourceTotal 0 + +abbrev TargetTotal0 (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) := + (K k n N d hd).TargetTotal 0 + +theorem sourceComponentType_eq + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).SourcePage 0 (-(m : ℤ)) = + QuotientOrderGradedPiece k (CI k n N d) m := + zeroPage_source_is_actual_graded_piece k n N m d hd + +theorem targetComponentType_eq + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (K k n N d hd).TargetPage 0 (-(m : ℤ)) = + QuotientOrderGradedPiece k (CI k n N d) m := + zeroPage_target_is_actual_graded_piece k n N m d hd + +/-- The total degree-zero source page is the actual order-associated graded module. -/ +noncomputable def sourceTotal0LinearEquivOrderAssociatedGraded + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + SourceTotal0 k n N d hd ≃ₗ[k] + OrderAssociatedGradedModule k (CI k n N d) := + nonpositiveDirectSumLinearEquiv k + (fun m => + (LinearEquiv.cast (M := fun p : ℤ => (K k n N d hd).SourcePage 0 p) + (negIndex_eq m)) ≪≫ₗ + zeroPageSourceLinearEquivOrderGradedPiece k n N m d hd) + (zeroPage_source_subsingleton_of_pos k n N · d hd) + +/-- The total degree-zero target page is the actual order-associated graded module. -/ +noncomputable def targetTotal0LinearEquivOrderAssociatedGraded + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + TargetTotal0 k n N d hd ≃ₗ[k] + OrderAssociatedGradedModule k (CI k n N d) := + nonpositiveDirectSumLinearEquiv k + (fun m => + (LinearEquiv.cast (M := fun p : ℤ => (K k n N d hd).TargetPage 0 p) + (negIndex_eq m)) ≪≫ₗ + zeroPageTargetLinearEquivOrderGradedPiece k n N m d hd) + (zeroPage_target_subsingleton_of_pos k n N · d hd) + +@[simp] theorem sourceTotal0LinearEquiv_lof_negIndex + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (x : (K k n N d hd).SourcePage 0 (negIndex m)) : + sourceTotal0LinearEquivOrderAssociatedGraded k n N d hd + (DirectSum.lof k ℤ (fun p => (K k n N d hd).SourcePage 0 p) + (negIndex m) x) = + orderAssociatedGradedOf k (CI k n N d) m + (((LinearEquiv.cast + (M := fun p : ℤ => (K k n N d hd).SourcePage 0 p) (negIndex_eq m)) ≪≫ₗ + zeroPageSourceLinearEquivOrderGradedPiece k n N m d hd) x) := by + exact nonpositiveDirectSumLinearEquiv_lof k _ _ m x + +@[simp] theorem targetTotal0LinearEquiv_lof_negIndex + (n N m : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (x : (K k n N d hd).TargetPage 0 (negIndex m)) : + targetTotal0LinearEquivOrderAssociatedGraded k n N d hd + (DirectSum.lof k ℤ (fun p => (K k n N d hd).TargetPage 0 p) + (negIndex m) x) = + orderAssociatedGradedOf k (CI k n N d) m + (((LinearEquiv.cast + (M := fun p : ℤ => (K k n N d hd).TargetPage 0 p) (negIndex_eq m)) ≪≫ₗ + zeroPageTargetLinearEquivOrderGradedPiece k n N m d hd) x) := by + exact nonpositiveDirectSumLinearEquiv_lof k _ _ m x + + +end +end Stafford38.Characteristic.CanonicalTotalGradedBridge diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitCoordinatePreimage.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitCoordinatePreimage.lean new file mode 100644 index 0000000000..6641794b0e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitCoordinatePreimage.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalMonicSaturation + +/-! +# A unit-only strict coordinate criterion for canonical axis avoidance + +The terminal axis-avoidance argument does not require coordinate cancellation +on every associated-graded piece. It only needs the degree-zero class of `1` +to lie in the image of the coordinate action. Equivalently, it is enough to +have one representative of order zero whose coordinate multiple equals `1` +in the literal canonical quotient. + +This file proves that this single strict unit preimage puts a relation +`P * X - 1` in the order initial ideal and hence excludes the distinguished +coordinate hyperplane from characteristic support. It also records that the +previous all-degree cancellation and strict-lower-preimage hypotheses imply +the unit-only condition. No converse is asserted. +-/ + +namespace Stafford38.CanonicalUnitCoordinatePreimage + +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.CanonicalMonicSaturation +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- The weakest concrete filtered input used by the terminal axis argument: +the quotient class of `1` has one coordinate predecessor of order zero. -/ +def StrictUnitCoordinatePreimage (n N : ℕ) + (d : PresentedWeyl k (n + 1)) : Prop := + ∃ y : PresentedWeyl k (n + 1), + y ∈ orderPiece k (n + 1) 0 ∧ + qmk (CanonicalIdeal k n N d) (y * presentedCoordinate k n) = + qmk (CanonicalIdeal k n N d) 1 + +/-- The previous all-degree cancellation hypothesis implies the unit-only +criterion, by strictifying an unrestricted preimage only at degree zero. -/ +theorem strictUnitCoordinatePreimage_of_coordinateCancellation + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (hcancel : CoordinateCancellation k n N d) : + StrictUnitCoordinatePreimage k n N d := by + obtain ⟨y, hy, hyx⟩ := exists_strict_coordinate_preimage + k n N 0 hd hcancel 1 (orderPieceOne (n := n + 1) k).property + exact ⟨y, hy, hyx⟩ + +omit [Algebra ℚ k] in +/-- Uniform strict-lower coordinate division is also stronger than necessary: +only its instance at cutoff `1` and target `1` is used here. -/ +theorem strictUnitCoordinatePreimage_of_strictLowerCoordinatePreimages + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hstrict : StrictLowerCoordinatePreimages k n N d) : + StrictUnitCoordinatePreimage k n N d := by + have hone : (1 : PresentedWeyl k (n + 1)) ∈ + presentedStrictLowerPiece k orderWeight 1 := by + change (1 : PresentedWeyl k (n + 1)) ∈ orderPiece k (n + 1) 0 + exact (orderPieceOne (n := n + 1) k).property + obtain ⟨y, hy, hyx⟩ := hstrict 1 1 hone + have hy0 : y ∈ orderPiece k (n + 1) 0 := by + change y ∈ orderPiece k (n + 1) 0 at hy + exact hy + exact ⟨y, hy0, hyx⟩ + +/-- A single strict unit preimage gives the exact degree-zero initial relation +needed for scheme-level coordinate-axis avoidance. -/ +theorem canonical_orderInitialIdeal_sup_coordinate_eq_top_of_strictUnit + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hunit : StrictUnitCoordinatePreimage k n N d) : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} = ⊤ := by + let I := CanonicalIdeal k n N d + let x := presentedCoordinate k n + obtain ⟨y, hy, hyx⟩ := hunit + have hx : x ∈ orderPiece k (n + 1) 0 := + presentedCoordinate_mem_orderPiece_zero k n + have hyxOrder : y * x ∈ orderPiece k (n + 1) 0 := + mul_mem_orderPiece k hy hx + have honeOrder : (1 : PresentedWeyl k (n + 1)) ∈ + orderPiece k (n + 1) 0 := + (orderPieceOne (n := n + 1) k).property + have hdiffOrder : y * x - 1 ∈ orderPiece k (n + 1) 0 := + (orderPiece k (n + 1) 0).sub_mem hyxOrder honeOrder + have hdiffIdeal : y * x - 1 ∈ I := + (Submodule.Quotient.eq I).mp hyx + have hrelation := principalComponent_mem_orderSymbolRelation + k I 0 (y * x - 1) hdiffOrder hdiffIdeal + have hinitial : + ((principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨y * x - 1, hdiffOrder⟩ : + MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0) : SymbolRing k (n + 1)) ∈ + orderInitialIdeal k I := + coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k I 0 _ hrelation + let Y : MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := + principalComponentOnPiece k (@orderWeight (n + 1)) 0 ⟨y, hy⟩ + have hYX : (Y : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) - 1 ∈ + orderInitialIdeal k I := by + convert hinitial using 1 + change (Y : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) - 1 = + presentedPrincipalComponent k orderWeight 0 (y * x - 1) + rw [map_sub, presentedPrincipalComponent_mul_order k hy hx] + have honePC : presentedPrincipalComponent k orderWeight 0 + (1 : PresentedWeyl k (n + 1)) = 1 := by + change presentedPrincipalComponent k orderWeight 0 + ((orderPieceOne (n := n + 1) k : orderPiece k (n + 1) 0) : + PresentedWeyl k (n + 1)) = 1 + exact presentedPrincipalComponent_orderPieceOne (n := n + 1) k + rw [honePC] + rw [show MvPolynomial.X (.inl (0 : Fin (n + 1))) = + presentedPrincipalComponent k orderWeight 0 x by + exact (coe_coordinate_order_symbol k n).symm] + change presentedPrincipalComponent k orderWeight 0 y * + presentedPrincipalComponent k orderWeight 0 x - 1 = _ + rfl + apply (Ideal.eq_top_iff_one _).2 + rw [show (1 : SymbolRing k (n + 1)) = + -((Y : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) - 1) + + (Y : SymbolRing k (n + 1)) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) by ring] + exact Submodule.add_mem _ + (Submodule.mem_sup_left ((orderInitialIdeal k I).neg_mem hYX)) + (Submodule.mem_sup_right (by + rw [Ideal.mem_span_singleton] + exact ⟨(Y : SymbolRing k (n + 1)), by rw [mul_comm]⟩)) + +/-- The terminal set-theoretic conclusion follows from the unit-only strict +preimage; neither all-degree cancellation nor graded injectivity is consumed. -/ +theorem canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus_of_strictUnit + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hunit : StrictUnitCoordinatePreimage k n N d) : + Disjoint + (orderCharacteristicSupport k (CanonicalIdeal k n N d)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + rw [Set.disjoint_left] + intro p hp hpx + rw [orderCharacteristicSupport_eq_zeroLocus, + PrimeSpectrum.mem_zeroLocus] at hp + rw [PrimeSpectrum.mem_zeroLocus] at hpx + have htop := + canonical_orderInitialIdeal_sup_coordinate_eq_top_of_strictUnit + k n N hunit + have hle : orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} ≤ p.asIdeal := + sup_le hp (Ideal.span_le.mpr hpx) + rw [htop] at hle + exact p.2.ne_top (top_unique hle) + + +end + +end Stafford38.CanonicalUnitCoordinatePreimage diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitPreimageFromInitialTop.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitPreimageFromInitialTop.lean new file mode 100644 index 0000000000..699cbeea65 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CanonicalUnitPreimageFromInitialTop.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitCoordinatePreimage + +/-! +# A strict unit preimage from degree-zero initial-ideal generation + +If the canonical order initial ideal and the distinguished coordinate symbol +generate the unit ideal, the degree-zero homogeneous part of that identity is +an exact order-symbol relation. An exact filtered representative of that +relation differs from `y * x - 1` by the strict lower order piece in degree +zero, which is zero. This produces the literal order-zero coordinate +predecessor required by `StrictUnitCoordinatePreimage`. + +No noncharacteristic or characteristic-variety theorem is used here. +-/ + +namespace Stafford38.CanonicalUnitPreimageFromInitialTop + +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.CanonicalUnitCoordinatePreimage +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylEulerResidue + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +private abbrev OrderHomogeneous (n N : ℕ) := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N + +private abbrev orderDecomposition (n : ℕ) := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance (n : ℕ) : + GradedAlgebra (orderDecomposition k n) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- The converse needed by the terminal cancellation route: unit generation +in the order initial ideal yields an actual order-zero coordinate predecessor +of the unit in the canonical right quotient. -/ +theorem strictUnitCoordinatePreimage_of_orderInitialIdeal_sup_coordinate_eq_top + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (htop : + orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} = ⊤) : + StrictUnitCoordinatePreimage k n N d := by + classical + let I := CanonicalIdeal k n N d + let x := presentedCoordinate k n + let X : OrderHomogeneous k (n + 1) 0 := + principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨x, presentedCoordinate_mem_orderPiece_zero k n⟩ + have hX : (X : SymbolRing k (n + 1)) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) := by + exact coe_coordinate_order_symbol k n + have honeSup : (1 : SymbolRing k (n + 1)) ∈ + orderInitialIdeal k I ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} := by + rw [show orderInitialIdeal k I ⊔ + Ideal.span {MvPolynomial.X (.inl (0 : Fin (n + 1)))} = ⊤ by + simpa [I] using htop] + exact Submodule.mem_top + obtain ⟨j, hj, s, hs, hjs⟩ := Submodule.mem_sup.mp honeSup + obtain ⟨a, ha⟩ := (Ideal.mem_span_singleton.mp hs) + have hsEq : s = a * (X : SymbolRing k (n + 1)) := by + calc + s = MvPolynomial.X (.inl (0 : Fin (n + 1))) * a := ha + _ = a * MvPolynomial.X (.inl (0 : Fin (n + 1))) := mul_comm _ _ + _ = a * (X : SymbolRing k (n + 1)) := by rw [hX] + have hrelationInitial : s - 1 ∈ orderInitialIdeal k I := by + have hsj : s - 1 = -j := by + rw [← hjs] + abel + rw [hsj] + exact (orderInitialIdeal k I).neg_mem hj + let A₀ : OrderHomogeneous k (n + 1) 0 := + DirectSum.decompose (orderDecomposition k (n + 1)) a 0 + let oneH : OrderHomogeneous k (n + 1) 0 := + ⟨1, MvPolynomial.isWeightedHomogeneous_one k orderWeight⟩ + have hprod : + (A₀ : SymbolRing k (n + 1)) * (X : SymbolRing k (n + 1)) ∈ + MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := by + simpa using A₀.property.mul X.property + have hdiffHom : + (A₀ : SymbolRing k (n + 1)) * (X : SymbolRing k (n + 1)) - 1 ∈ + MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0 := + (MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1)) 0).sub_mem hprod oneH.property + have hcomponent : + DirectSum.decompose (orderDecomposition k (n + 1)) (s - 1) 0 = + ⟨(A₀ : SymbolRing k (n + 1)) * (X : SymbolRing k (n + 1)) - 1, + hdiffHom⟩ := by + apply Subtype.ext + rw [DirectSum.decompose_sub, hsEq] + have hmul := DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition k (n + 1)) X.property (Nat.zero_le 0) + (a := a) (n := 0) + change ((DirectSum.decompose (orderDecomposition k (n + 1)) + (a * (X : SymbolRing k (n + 1))) 0 : + OrderHomogeneous k (n + 1) 0) : SymbolRing k (n + 1)) - + ((DirectSum.decompose (orderDecomposition k (n + 1)) + (1 : SymbolRing k (n + 1)) 0 : + OrderHomogeneous k (n + 1) 0) : SymbolRing k (n + 1)) = _ + rw [hmul] + have honeDecomp : + DirectSum.decompose (orderDecomposition k (n + 1)) + (1 : SymbolRing k (n + 1)) 0 = oneH := by + change DirectSum.decompose (orderDecomposition k (n + 1)) + (oneH : SymbolRing k (n + 1)) 0 = oneH + simp only [DirectSum.decompose_coe, DirectSum.of_eq_same] + rw [honeDecomp] + have hcomponentRelation : + DirectSum.decompose (orderDecomposition k (n + 1)) (s - 1) 0 ∈ + orderSymbolRelation k I 0 := + decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k I (s - 1) hrelationInitial 0 + rw [hcomponent] at hcomponentRelation + obtain ⟨yPiece, hySymbol⟩ := + principalComponentOnPiece_surjective k (@orderWeight (n + 1)) A₀ + let y : PresentedWeyl k (n + 1) := yPiece + have hy : y ∈ orderPiece k (n + 1) 0 := yPiece.property + have hx : x ∈ orderPiece k (n + 1) 0 := + presentedCoordinate_mem_orderPiece_zero k n + have hyxOne : y * x - 1 ∈ orderPiece k (n + 1) 0 := + (orderPiece k (n + 1) 0).sub_mem + (mul_mem_orderPiece k hy hx) + (orderPieceOne (n := n + 1) k).property + let relationH : OrderHomogeneous k (n + 1) 0 := + ⟨(A₀ : SymbolRing k (n + 1)) * (X : SymbolRing k (n + 1)) - 1, + hdiffHom⟩ + have hrelationH : relationH ∈ orderSymbolRelation k I 0 := by + exact hcomponentRelation + obtain ⟨z, hz, hzI, hzSymbol⟩ := + (mem_orderSymbolRelation_iff k I 0 relationH).mp hrelationH + have hpcEq : + principalComponentOnPiece k (@orderWeight (n + 1)) 0 + ⟨y * x - 1, hyxOne⟩ = + principalComponentOnPiece k (@orderWeight (n + 1)) 0 ⟨z, hz⟩ := by + rw [← hzSymbol] + apply Subtype.ext + change presentedPrincipalComponent k orderWeight 0 (y * x - 1) = + (relationH : SymbolRing k (n + 1)) + rw [map_sub, presentedPrincipalComponent_mul_order k hy hx] + have honePC : presentedPrincipalComponent k orderWeight 0 + (1 : PresentedWeyl k (n + 1)) = 1 := by + change presentedPrincipalComponent k orderWeight 0 + ((orderPieceOne (n := n + 1) k : orderPiece k (n + 1) 0) : + PresentedWeyl k (n + 1)) = 1 + exact presentedPrincipalComponent_orderPieceOne (n := n + 1) k + rw [honePC] + change presentedPrincipalComponent k orderWeight 0 y * + presentedPrincipalComponent k orderWeight 0 x - 1 = _ + rw [show presentedPrincipalComponent k orderWeight 0 y = + (A₀ : SymbolRing k (n + 1)) by + exact congrArg Subtype.val hySymbol] + change (A₀ : SymbolRing k (n + 1)) * + presentedPrincipalComponent k orderWeight 0 x - 1 = _ + rw [show presentedPrincipalComponent k orderWeight 0 x = + (X : SymbolRing k (n + 1)) by rfl] + have heq : y * x - 1 = z := by + have hdiffPiece : y * x - 1 - z ∈ orderPiece k (n + 1) 0 := + (orderPiece k (n + 1) 0).sub_mem hyxOne hz + have hzero : presentedPrincipalComponent k orderWeight 0 + (y * x - 1 - z) = 0 := by + rw [map_sub] + exact sub_eq_zero.mpr (congrArg + (fun q : OrderHomogeneous k (n + 1) 0 => + (q : SymbolRing k (n + 1))) hpcEq) + have hlower := (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight (n + 1)) (y * x - 1 - z) hdiffPiece).mp hzero + change y * x - 1 - z ∈ (⊥ : Submodule k (PresentedWeyl k (n + 1))) at hlower + rw [Submodule.mem_bot] at hlower + exact sub_eq_zero.mp hlower + refine ⟨y, hy, ?_⟩ + apply (Submodule.Quotient.eq I).2 + change y * x - 1 ∈ I + rw [heq] + exact hzI + + +end + +end Stafford38.CanonicalUnitPreimageFromInitialTop diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/CommutingPolynomialAction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/CommutingPolynomialAction.lean new file mode 100644 index 0000000000..efab349cbe --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/CommutingPolynomialAction.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.CommutingPolynomialAction + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic + +export AlgebraicAnalysis.CommutingPolynomialAction (commutingPolynomialAction commutingPolynomialAction_apply_X commutingPolynomialAction_apply_C commutingPolynomialAction_intertwines commutingPolynomialModule) + +end Stafford38.Characteristic diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteEquation33SourceMatrices.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteEquation33SourceMatrices.lean new file mode 100644 index 0000000000..dd05512594 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteEquation33SourceMatrices.lean @@ -0,0 +1,627 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianAdaptedBasisExistence +import LeanPool.Stafford38.Stafford38.Characteristic.ArtinianEquation33TraceProducer + +/-! +# Source matrices for the concrete equation-(3.3) bridge + +This file carries out the source-level matrix algebra that precedes the trace +argument in Singh--Kumar, Proposition 3.2. It deliberately keeps the +deformation ring noncommutative and preserves the written left-factor +orientation of the central parameter. + +For strict lifted zeroth-order matrices `A` and `B`, it constructs the three +strict parameter cofactors `X`, `Y`, and `Omega` in + +`[x,B] = cX`, `[y,A] = cY`, and `[B,A] = cOmega`. + +For arbitrary first-order matrices `Gamma` and `Theta`, it also constructs +literal cofactors for the traces of `[Theta,A]` and `[B,Gamma]`. Hence the +matrix represented by equation (3.3) has zero trace after parameter and +coefficient-field reduction. The concrete localized two-block +specialization is packaged as the required principal parameter reduction. + +The file does not identify this reduced matrix with the operator induced by +the bracket cofactor `z` on the concrete localized module. That is the first +remaining source-specific action identity; its exact signature is recorded at +the end, without claiming the final operator trace. +-/ + +namespace Stafford38.Characteristic.ConcreteEquation33SourceMatrices + +open Matrix +open Stafford38.Characteristic +open Stafford38.Characteristic.ArtinianAdaptedBasisExistence +open Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +open Stafford38.Characteristic.ArtinianEquation33TraceProducer +open Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre +open Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +section PrincipalReduction + +variable {B Abar : Type u} [Ring B] [CommRing Abar] + +/-- A surjective reduction with an exact written-order left-principal kernel. +This is the elementwise form supplied by the concrete localized Rees +specialization. -/ +structure LeftPrincipalParameterReduction where + parameter : B + modParameter : B →+* Abar + surjective : Function.Surjective modParameter + parameter_comm : ∀ z : B, parameter * z = z * parameter + kernel_left : ∀ z : B, + modParameter z = 0 ↔ ∃ w : B, parameter * w = z + +/-- The source's ideal-valued reduction follows from the stronger explicit +left-principal kernel, using centrality only to match Mathlib's left-ideal +generator convention. -/ +def LeftPrincipalParameterReduction.toParameterIdealReduction + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) : + ParameterIdealReduction B Abar where + parameter := S.parameter + modParameter := S.modParameter + ker_modParameter := by + ext z + constructor + · intro hz + obtain ⟨w, hw⟩ := (S.kernel_left z).1 hz + rw [Ideal.mem_span_singleton'] + exact ⟨w, (S.parameter_comm w).symm.trans hw⟩ + · intro hz + rw [Ideal.mem_span_singleton'] at hz + obtain ⟨w, rfl⟩ := hz + rw [← S.parameter_comm w] + exact (S.kernel_left (S.parameter * w)).2 ⟨w, rfl⟩ + +/-- A zero-preserving choice of a lift through a surjective reduction. -/ +def zeroPreservingLift + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (z : Abar) : B := by + classical + exact if hz : z = 0 then 0 else Classical.choose (S.surjective z) + +@[simp] +theorem modParameter_zeroPreservingLift + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (z : Abar) : + S.modParameter (zeroPreservingLift S z) = z := by + classical + by_cases hz : z = 0 + · simp [zeroPreservingLift, hz] + · simpa [zeroPreservingLift, hz] using Classical.choose_spec (S.surjective z) + +@[simp] +theorem zeroPreservingLift_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) : + zeroPreservingLift S 0 = 0 := by + classical + simp [zeroPreservingLift] + +/-- A zero-preserving written-order parameter cofactor. -/ +def principalCofactor + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (z : B) : B := by + classical + exact if hz : z = 0 then 0 + else if hker : S.modParameter z = 0 then + Classical.choose ((S.kernel_left z).1 hker) + else 0 + +theorem parameter_mul_principalCofactor + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + {z : B} (hz : S.modParameter z = 0) : + S.parameter * principalCofactor S z = z := by + classical + by_cases hzero : z = 0 + · simp [principalCofactor, hzero] + · simp only [principalCofactor, hzero, hz, ↓reduceDIte] + exact Classical.choose_spec ((S.kernel_left z).1 hz) + +@[simp] +theorem principalCofactor_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) : + principalCofactor S 0 = 0 := by + classical + simp [principalCofactor] + +end PrincipalReduction + +section MatrixAlgebra + +variable {B Abar K : Type u} +variable [Ring B] [CommRing Abar] [Field K] +variable {n : ℕ} + +/-- Entrywise scalar commutator, in the order used in equation (3.3). -/ +def scalarMatrixCommutator + (x : B) (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + Matrix (Fin (n + 1)) (Fin (n + 1)) B := + fun i j => x * M i j - M i j * x + +/-- Written-order matrix commutator over the deformation ring. -/ +def sourceMatrixCommutator + (M N : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + Matrix (Fin (n + 1)) (Fin (n + 1)) B := + M * N - N * M + +/-- Coefficientwise zero-preserving lift of a matrix. -/ +def liftMatrix + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) Abar) : + Matrix (Fin (n + 1)) (Fin (n + 1)) B := + fun i j => zeroPreservingLift S (M i j) + +@[simp] +theorem liftMatrix_map + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) Abar) : + (liftMatrix S M).map S.modParameter = M := by + ext i j + simp [liftMatrix, Matrix.map_apply] + +theorem liftMatrix_isStrictUpperTriangular + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) Abar) + (hM : IsStrictUpperTriangularOver M) : + IsStrictUpperTriangularOver (liftMatrix S M) := by + intro i j hji + simp [liftMatrix, hM i j hji] + +/-- Entrywise parameter cofactor of a matrix whose reduction vanishes. -/ +def factorMatrix + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + Matrix (Fin (n + 1)) (Fin (n + 1)) B := + fun i j => principalCofactor S (M i j) + +theorem parameter_mul_factorMatrix + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hM : M.map S.modParameter = 0) : + ∀ i j, S.parameter * factorMatrix S M i j = M i j := by + intro i j + apply parameter_mul_principalCofactor S + have hij := congrArg (fun Q => Q i j) hM + simpa [Matrix.map_apply] using hij + +theorem factorMatrix_isStrictUpperTriangular + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hM : IsStrictUpperTriangularOver M) : + IsStrictUpperTriangularOver (factorMatrix S M) := by + intro i j hji + simp [factorMatrix, hM i j hji] + +theorem scalarMatrixCommutator_map_eq_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (x : B) (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + (scalarMatrixCommutator x M).map S.modParameter = 0 := by + ext i j + simp [scalarMatrixCommutator, Matrix.map_apply, mul_comm] + +theorem scalarMatrixCommutator_isStrictUpperTriangular + (x : B) (M : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hM : IsStrictUpperTriangularOver M) : + IsStrictUpperTriangularOver (scalarMatrixCommutator x M) := by + intro i j hji + simp [scalarMatrixCommutator, hM i j hji] + +theorem mul_isStrictUpperTriangular + (M N : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hM : IsStrictUpperTriangularOver M) + (hN : IsStrictUpperTriangularOver N) : + IsStrictUpperTriangularOver (M * N) := by + intro i j hji + rw [Matrix.mul_apply] + apply Finset.sum_eq_zero + intro a _ha + rcases le_total a i with hai | hia + · rw [hM i a hai, zero_mul] + · rw [hN a j (hji.trans hia), mul_zero] + +theorem sourceMatrixCommutator_isStrictUpperTriangular + (M N : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hM : IsStrictUpperTriangularOver M) + (hN : IsStrictUpperTriangularOver N) : + IsStrictUpperTriangularOver (sourceMatrixCommutator M N) := by + intro i j hji + simp [sourceMatrixCommutator, + mul_isStrictUpperTriangular M N hM hN i j hji, + mul_isStrictUpperTriangular N M hN hM i j hji] + +theorem sourceMatrixCommutator_map_eq_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M N : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hcomm : M.map S.modParameter * N.map S.modParameter = + N.map S.modParameter * M.map S.modParameter) : + (sourceMatrixCommutator M N).map S.modParameter = 0 := by + ext i j + have hij := congrArg (fun Q => Q i j) hcomm + change S.modParameter ((M * N) i j - (N * M) i j) = 0 + rw [S.modParameter.map_sub, Matrix.mul_apply, Matrix.mul_apply] + simp only [map_sum, S.modParameter.map_mul] + simpa [Matrix.mul_apply, Matrix.map_apply] using sub_eq_zero.mpr hij + +/-- Although matrix multiplication need not commute after reduction, the +trace of a reduced matrix commutator vanishes over the commutative special +fibre. -/ +theorem sourceMatrixCommutator_map_trace_eq_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (M N : Matrix (Fin (n + 1)) (Fin (n + 1)) B) : + Matrix.trace ((sourceMatrixCommutator M N).map S.modParameter) = 0 := by + have hmap : (sourceMatrixCommutator M N).map S.modParameter = + M.map S.modParameter * N.map S.modParameter - + N.map S.modParameter * M.map S.modParameter := by + ext i j + simp [sourceMatrixCommutator, Matrix.map_apply, Matrix.mul_apply] + rw [hmap, Matrix.trace_sub, Matrix.trace_mul_comm, sub_self] + +/-- The five cofactors retained from the primary-source calculation: three +strict matrix cofactors and two scalar trace cofactors. -/ +structure Equation33Cofactors + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (x y : B) + (A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B) where + X : Matrix (Fin (n + 1)) (Fin (n + 1)) B + Y : Matrix (Fin (n + 1)) (Fin (n + 1)) B + Omega : Matrix (Fin (n + 1)) (Fin (n + 1)) B + tauThetaA : B + tauBGamma : B + xB_eq : ∀ i j, S.parameter * X i j = scalarMatrixCommutator x Bm i j + yA_eq : ∀ i j, S.parameter * Y i j = scalarMatrixCommutator y A i j + BA_eq : ∀ i j, + S.parameter * Omega i j = sourceMatrixCommutator Bm A i j + X_strict : IsStrictUpperTriangularOver X + Y_strict : IsStrictUpperTriangularOver Y + Omega_strict : IsStrictUpperTriangularOver Omega + trace_ThetaA_eq : + S.parameter * tauThetaA = Matrix.trace (sourceMatrixCommutator Theta A) + trace_BGamma_eq : + S.parameter * tauBGamma = Matrix.trace (sourceMatrixCommutator Bm Gamma) + +/-- The source cofactors are constructed, not assumed. -/ +def equation33Cofactors + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (x y : B) + (A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hA : IsStrictUpperTriangularOver A) + (hB : IsStrictUpperTriangularOver Bm) + (hBAcomm : Bm.map S.modParameter * A.map S.modParameter = + A.map S.modParameter * Bm.map S.modParameter) : + Equation33Cofactors S x y A Bm Gamma Theta := by + let X := factorMatrix S (scalarMatrixCommutator x Bm) + let Y := factorMatrix S (scalarMatrixCommutator y A) + let Omega := factorMatrix S (sourceMatrixCommutator Bm A) + let tauThetaA := principalCofactor S + (Matrix.trace (sourceMatrixCommutator Theta A)) + let tauBGamma := principalCofactor S + (Matrix.trace (sourceMatrixCommutator Bm Gamma)) + refine + { X := X + Y := Y + Omega := Omega + tauThetaA := tauThetaA + tauBGamma := tauBGamma + xB_eq := parameter_mul_factorMatrix S _ + (scalarMatrixCommutator_map_eq_zero S x Bm) + yA_eq := parameter_mul_factorMatrix S _ + (scalarMatrixCommutator_map_eq_zero S y A) + BA_eq := parameter_mul_factorMatrix S _ + (sourceMatrixCommutator_map_eq_zero S Bm A hBAcomm) + X_strict := factorMatrix_isStrictUpperTriangular S _ + (scalarMatrixCommutator_isStrictUpperTriangular x Bm hB) + Y_strict := factorMatrix_isStrictUpperTriangular S _ + (scalarMatrixCommutator_isStrictUpperTriangular y A hA) + Omega_strict := factorMatrix_isStrictUpperTriangular S _ + (sourceMatrixCommutator_isStrictUpperTriangular Bm A hB hA) + trace_ThetaA_eq := ?_ + trace_BGamma_eq := ?_ } + · apply parameter_mul_principalCofactor S + calc + S.modParameter (Matrix.trace (sourceMatrixCommutator Theta A)) = + Matrix.trace ((sourceMatrixCommutator Theta A).map S.modParameter) := by + simpa using + (AddMonoidHom.map_trace S.modParameter.toAddMonoidHom + (sourceMatrixCommutator Theta A)) + _ = 0 := sourceMatrixCommutator_map_trace_eq_zero S Theta A + · apply parameter_mul_principalCofactor S + calc + S.modParameter (Matrix.trace (sourceMatrixCommutator Bm Gamma)) = + Matrix.trace ((sourceMatrixCommutator Bm Gamma).map S.modParameter) := by + simpa using + (AddMonoidHom.map_trace S.modParameter.toAddMonoidHom + (sourceMatrixCommutator Bm Gamma)) + _ = 0 := sourceMatrixCommutator_map_trace_eq_zero S Bm Gamma + +/-- The strict remainder `R = X - Y + Omega` from equation (3.3). -/ +def sourceStrictRemainder + {S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)} + {x y : B} {A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B} + (C : Equation33Cofactors S x y A Bm Gamma Theta) : + Matrix (Fin (n + 1)) (Fin (n + 1)) B := + C.X - C.Y + C.Omega + +theorem sourceStrictRemainder_isStrictUpperTriangular + {S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)} + {x y : B} {A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B} + (C : Equation33Cofactors S x y A Bm Gamma Theta) : + IsStrictUpperTriangularOver (sourceStrictRemainder C) := by + intro i j hji + simp [sourceStrictRemainder, C.X_strict i j hji, + C.Y_strict i j hji, C.Omega_strict i j hji] + +/-- The two correction matrices `Q1=[Theta,A]` and `Q2=[B,Gamma]`. -/ +def sourceCorrectionThetaA + (Theta A : Matrix (Fin (n + 1)) (Fin (n + 1)) B) := + sourceMatrixCommutator Theta A + +def sourceCorrectionBGamma + (Bm Gamma : Matrix (Fin (n + 1)) (Fin (n + 1)) B) := + sourceMatrixCommutator Bm Gamma + +theorem correctionThetaA_traceInParameter + {S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)} + {x y : B} {A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B} + (C : Equation33Cofactors S x y A Bm Gamma Theta) : + CorrectionTraceInParameter S.toParameterIdealReduction + (sourceCorrectionThetaA Theta A) := by + rw [CorrectionTraceInParameter, Ideal.mem_span_singleton'] + exact ⟨C.tauThetaA, + (S.parameter_comm C.tauThetaA).symm.trans C.trace_ThetaA_eq⟩ + +theorem correctionBGamma_traceInParameter + {S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)} + {x y : B} {A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B} + (C : Equation33Cofactors S x y A Bm Gamma Theta) : + CorrectionTraceInParameter S.toParameterIdealReduction + (sourceCorrectionBGamma Bm Gamma) := by + rw [CorrectionTraceInParameter, Ideal.mem_span_singleton'] + exact ⟨C.tauBGamma, + (S.parameter_comm C.tauBGamma).symm.trans C.trace_BGamma_eq⟩ + +/-- Literal trace-zero conclusion for the matrix produced by the source +cofactors. This consumes the faithful equation-(3.3) trace reducer, not the +stronger same-size coefficient-field commutator surrogate. -/ +theorem sourceReducedEquation33Matrix_trace_eq_zero + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (residue : Abar →+* K) + (x y : B) + (A Bm Gamma Theta : Matrix (Fin (n + 1)) (Fin (n + 1)) B) + (hA : IsStrictUpperTriangularOver A) + (hB : IsStrictUpperTriangularOver Bm) + (hBAcomm : Bm.map S.modParameter * A.map S.modParameter = + A.map S.modParameter * Bm.map S.modParameter) : + Matrix.trace + (reducedEquation33Matrix S.toParameterIdealReduction residue + (sourceStrictRemainder + (equation33Cofactors S x y A Bm Gamma Theta hA hB hBAcomm)) + (sourceCorrectionThetaA Theta A) + (sourceCorrectionBGamma Bm Gamma)) = 0 := by + let C := equation33Cofactors S x y A Bm Gamma Theta hA hB hBAcomm + exact reducedEquation33Matrix_trace_eq_zero + S.toParameterIdealReduction residue + (sourceStrictRemainder C) + (sourceCorrectionThetaA Theta A) + (sourceCorrectionBGamma Bm Gamma) + (sourceStrictRemainder_isStrictUpperTriangular C) + (correctionThetaA_traceInParameter C) + (correctionBGamma_traceInParameter C) + +end MatrixAlgebra + +section AdaptedActionMatrices + +variable {K R V B : Type u} +variable [Field K] [CommRing R] [Algebra K R] [IsLocalRing R] +variable [IsArtinianRing R] +variable [AddCommGroup V] [Module K V] [Module R V] [IsScalarTower K R V] +variable [FiniteDimensional K V] +variable [Ring B] +variable {n : ℕ} + +local notation "m" => IsLocalRing.maximalIdeal R + +/-- The literal matrix of multiplication by a special-fibre element. This is +the operator that equation (3.3) must identify when the element is the +bracket cofactor `z`. -/ +def inducedSpecialFibreActionMatrix + (b : Module.Basis (Fin (n + 1)) K V) (zbar : R) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) zbar) + +/-- The source uses row vectors, whereas `LinearMap.toMatrix` uses the usual +column convention. Transposition is therefore part of the literal +source-to-Lean adapter. -/ +def inducedSpecialFibreSourceMatrix + (b : Module.Basis (Fin (n + 1)) K V) (zbar : R) : + Matrix (Fin (n + 1)) (Fin (n + 1)) K := + (inducedSpecialFibreActionMatrix b zbar)ᵀ + +/-- Actual zeroth-order adapted-basis action matrices in Lean's column +convention, with strict zero-preserving lifts to the deformation ring. The +returned lifts `x` and `y` specialize to the requested elements. Passing to +the source's row convention requires the explicit transpose adapter above. -/ +theorem exists_lifted_adapted_actionMatrices + (S : LeftPrincipalParameterReduction (B := B) (Abar := R)) + (hdim : Module.finrank K V = n + 1) + (xbar ybar : R) (hx : xbar ∈ m) (hy : ybar ∈ m) : + ∃ (b : Module.Basis (Fin (n + 1)) K V) + (level : Fin (n + 1) → ℕ) + (x y : B) + (A Bm : Matrix (Fin (n + 1)) (Fin (n + 1)) B), + IsMaximalIdealFiltrationAdapted m b level ∧ + S.modParameter x = xbar ∧ + S.modParameter y = ybar ∧ + A.map S.modParameter = + (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) xbar)).map + (algebraMap K R) ∧ + Bm.map S.modParameter = + (LinearMap.toMatrix b b + (leftMultiplicationEnd (K := K) (V := V) ybar)).map + (algebraMap K R) ∧ + IsStrictUpperTriangularOver A ∧ + IsStrictUpperTriangularOver Bm ∧ + Bm.map S.modParameter * A.map S.modParameter = + A.map S.modParameter * Bm.map S.modParameter := by + obtain ⟨b, level, hadapted⟩ := + exists_maximalIdealFiltrationAdaptedBasis (K := K) (R := R) (V := V) hdim + let Ax := leftMultiplicationEnd (K := K) (V := V) xbar + let By := leftMultiplicationEnd (K := K) (V := V) ybar + let A0K := LinearMap.toMatrix b b Ax + let B0K := LinearMap.toMatrix b b By + let A0 := A0K.map (algebraMap K R) + let B0 := B0K.map (algebraMap K R) + let A := liftMatrix S A0 + let Bm := liftMatrix S B0 + let x := zeroPreservingLift S xbar + let y := zeroPreservingLift S ybar + have hA0K : IsStrictUpperTriangularOver A0K := + leftMultiplicationMatrix_isStrictUpperTriangular b level hadapted hx + have hB0K : IsStrictUpperTriangularOver B0K := + leftMultiplicationMatrix_isStrictUpperTriangular b level hadapted hy + have hA0 : IsStrictUpperTriangularOver A0 := + fun i j hji => by simp [A0, Matrix.map_apply, hA0K i j hji] + have hB0 : IsStrictUpperTriangularOver B0 := + fun i j hji => by simp [B0, Matrix.map_apply, hB0K i j hji] + have hEnd : By * Ax = Ax * By := by + ext v + change ybar • xbar • v = xbar • ybar • v + rw [← mul_smul, ← mul_smul, mul_comm] + have hK : B0K * A0K = A0K * B0K := by + rw [← LinearMap.toMatrix_mul, ← LinearMap.toMatrix_mul, hEnd] + have hcomm : B0 * A0 = A0 * B0 := by + change B0K.map (algebraMap K R) * A0K.map (algebraMap K R) = + A0K.map (algebraMap K R) * B0K.map (algebraMap K R) + rw [← Matrix.map_mul, ← Matrix.map_mul, hK] + exact ⟨b, level, x, y, A, Bm, hadapted, + modParameter_zeroPreservingLift S xbar, + modParameter_zeroPreservingLift S ybar, + liftMatrix_map S A0, + liftMatrix_map S B0, + liftMatrix_isStrictUpperTriangular S A0 hA0, + liftMatrix_isStrictUpperTriangular S B0 hB0, by + rw [liftMatrix_map, liftMatrix_map] + exact hcomm⟩ + +end AdaptedActionMatrices + +section ConcreteReduction + +variable (k : Type u) [Field k] +variable {n : ℕ} +variable (I : RightIdeal (PresentedWeyl k n)) +variable (S : Submonoid (SymbolRing k n)) +variable [OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) S)] +variable [IsLocalRing (Localization S)] + +private abbrev concreteData := filteredQuotientTwoJetTraceData k I + +local notation "D" => concreteData k I + +/-- The concrete localized two-block quotient has exactly the principal +parameter reduction required by the source matrix construction. -/ +def concreteLeftPrincipalParameterReduction (q : ℕ) : + LeftPrincipalParameterReduction + (B := LocalizedTwoBlockRing D S q) + (Abar := (Localization S) ⧸ localizedDoubledPower S q) where + parameter := concreteLocalizedTwoBlockParameter k I S q + modParameter := localizedTwoBlockSpecialization D S q + surjective := localizedTwoBlockSpecialization_surjective D S q + parameter_comm := by + intro z + induction z using Quotient.inductionOn' with + | _ a => + change + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k))) * + (localizedTwoBlockIdeal D S q).ringCon.mk' a = _ + calc + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k))) * + (localizedTwoBlockIdeal D S q).ringCon.mk' a = + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) * a) := by + exact ((localizedTwoBlockIdeal D S q).ringCon.mk').map_mul _ _ |>.symm + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' + (a * OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k))) := by + exact congrArg ((localizedTwoBlockIdeal D S q).ringCon.mk') + (localizedParameter_comm D S a) + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' a * + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k))) := by + exact ((localizedTwoBlockIdeal D S q).ringCon.mk').map_mul _ _ + kernel_left := + concreteLocalizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + k I S q + +/-- The exact remaining source-specific bridge. The left side is the actual +matrix of the operator induced by the bracket cofactor `z` on the coefficient +field special fibre. The right side is the matrix already constructed from +the lifted adapted basis and all five explicit equation-(3.3) cofactors. + +No inhabitant is constructed here: proving this equality requires the lifted +basis-vector action equations in the concrete localized module. In +particular, this definition is not a trace-zero theorem. -/ +def ConcreteInducedZActionIdentity + {K V : Type u} [Field K] + [AddCommGroup V] + {q r : ℕ} + (parameterReduction : LeftPrincipalParameterReduction + (B := LocalizedTwoBlockRing D S q) + (Abar := (Localization S) ⧸ localizedDoubledPower S q)) + (residue : ((Localization S) ⧸ localizedDoubledPower S q) →+* K) + [Algebra K ((Localization S) ⧸ localizedDoubledPower S q)] + [Module K V] + [Module ((Localization S) ⧸ localizedDoubledPower S q) V] + [IsScalarTower K ((Localization S) ⧸ localizedDoubledPower S q) V] + (b : Module.Basis (Fin (r + 1)) K V) + (zbar : (Localization S) ⧸ localizedDoubledPower S q) + (x y : LocalizedTwoBlockRing D S q) + (A Bm Gamma Theta : + Matrix (Fin (r + 1)) (Fin (r + 1)) (LocalizedTwoBlockRing D S q)) + (hA : IsStrictUpperTriangularOver A) + (hB : IsStrictUpperTriangularOver Bm) + (hBAcomm : Bm.map parameterReduction.modParameter * + A.map parameterReduction.modParameter = + A.map parameterReduction.modParameter * + Bm.map parameterReduction.modParameter) : Prop := + let C := equation33Cofactors parameterReduction x y A Bm Gamma Theta + hA hB hBAcomm + inducedSpecialFibreSourceMatrix b zbar = + reducedEquation33Matrix parameterReduction.toParameterIdealReduction residue + (sourceStrictRemainder C) + (sourceCorrectionThetaA Theta A) + (sourceCorrectionBGamma Bm Gamma) + + +end ConcreteReduction + +end + +end Stafford38.Characteristic.ConcreteEquation33SourceMatrices diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteInducedZAction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteInducedZAction.lean new file mode 100644 index 0000000000..388b00bd4d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteInducedZAction.lean @@ -0,0 +1,625 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteEquation33SourceMatrices +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockModuleExactness +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedSpecializationActionCompatibility + +/-! +# Concrete lifted source-basis action equations + +This file constructs the first-order source-row matrix attached to an actual +square-zero deformation module. The construction uses only the surjective +module specialization, its exact parameter kernel, and a basis of the special +fibre. In particular, no scalar action on the deformation module by the +coefficient field is introduced. + +The row convention is literal: entry `(i,j)` is the coefficient of the lifted +basis vector `j` in the action on lifted basis vector `i`. This is the +transpose of Mathlib's `LinearMap.toMatrix` convention. For the localized +two-block module the abstract construction is instantiated with the descended +quotient-ring action and the localized opposite-ring specialization. + +The induced `z`-operator identity is not assumed in this file. Its proof also +requires expanding the commutator of the two constructed action equations and +descending the resulting parameter-multiple equality through exactness. +-/ + +namespace Stafford38.Characteristic.ConcreteInducedZAction + +open Matrix +open Stafford38.Characteristic +open Stafford38.Characteristic.ArtinianAdaptedBasisTraceAdapter +open Stafford38.Characteristic.ConcreteEquation33SourceMatrices +open Stafford38.Characteristic.LocalizedSpecializationActionCompatibility +open Stafford38.Characteristic.LocalizedTwoBlockModuleExactness +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + + +universe u + +section AbstractSourceEquation + +variable {B Abar K W V : Type u} +variable [Ring B] [CommRing Abar] [Field K] +variable [AddCommGroup W] [Module B W] +variable [AddCommGroup V] [Module K V] [Module Abar V] +variable [Algebra K Abar] [IsScalarTower K Abar V] +variable {r : ℕ} + +/-- Additive action of the deformation parameter on the module. -/ +def parameterAct (c : B) : W →+ W where + toFun w := c • w + map_zero' := smul_zero c + map_add' x y := smul_add c x y + +@[simp] theorem parameterAct_apply (c : B) (w : W) : + parameterAct (W := W) c w = c • w := rfl + +/-- A fixed lift of every basis vector through a surjective specialization. +Calling the construction for two operators therefore uses the same lifted +basis, as required in the source calculation. -/ +def liftedBasisVector + (rho : W →+ V) (hrho : Function.Surjective rho) + (b : Module.Basis (Fin (r + 1)) K V) (i : Fin (r + 1)) : W := + Classical.choose (hrho (b i)) + +@[simp] theorem rho_liftedBasisVector + (rho : W →+ V) (hrho : Function.Surjective rho) + (b : Module.Basis (Fin (r + 1)) K V) (i : Fin (r + 1)) : + rho (liftedBasisVector rho hrho b i) = b i := + Classical.choose_spec (hrho (b i)) + +/-- Source-row coefficients of an endomorphism. The first index names the +input basis vector, and the second names an output coefficient. -/ +def sourceActionCoefficients + (b : Module.Basis (Fin (r + 1)) K V) (T : Module.End K V) : + Matrix (Fin (r + 1)) (Fin (r + 1)) Abar := + fun i j ↦ algebraMap K Abar (b.repr (T (b i)) j) + +/-- The source-row coefficient matrix is the transpose of Mathlib's column +matrix, followed by coefficient-field inclusion. -/ +theorem sourceActionCoefficients_eq_transpose_toMatrix_map + (b : Module.Basis (Fin (r + 1)) K V) (T : Module.End K V) : + sourceActionCoefficients (Abar := Abar) b T = + (LinearMap.toMatrix b b T)ᵀ.map (algebraMap K Abar) := by + ext i j + simp [sourceActionCoefficients, LinearMap.toMatrix_apply, Matrix.map_apply] + +/-- The row coefficients reconstruct the action on the named input vector. -/ +theorem sum_sourceActionCoefficients_smul + (b : Module.Basis (Fin (r + 1)) K V) (T : Module.End K V) + (i : Fin (r + 1)) : + (∑ j, sourceActionCoefficients (Abar := Abar) b T i j • b j) = + T (b i) := by + simpa [sourceActionCoefficients, IsScalarTower.algebraMap_smul] + using b.sum_repr (T (b i)) + +/-- Lift the source-row coefficients entrywise through the parameter +reduction. -/ +def liftedSourceActionMatrix + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (b : Module.Basis (Fin (r + 1)) K V) (T : Module.End K V) : + Matrix (Fin (r + 1)) (Fin (r + 1)) B := + liftMatrix S (sourceActionCoefficients (Abar := Abar) b T) + +@[simp] theorem liftedSourceActionMatrix_map + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (b : Module.Basis (Fin (r + 1)) K V) (T : Module.End K V) : + (liftedSourceActionMatrix S b T).map S.modParameter = + sourceActionCoefficients (Abar := Abar) b T := + liftMatrix_map S _ + +/-- Exact first-order source-basis action equation. + +The matrix `Gamma` is constructed from the two exactness statements. First, +the zeroth-order error is lifted through `ker rho = range(c)`. Its chosen +preimage is expanded in the special-fibre basis; after lifting those scalar +coordinates, the remaining error again lies in `range(c)`, and multiplication +by the square-zero parameter kills it. -/ +theorem exists_firstOrderSourceActionMatrix_over_coefficientField + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hrho_action : ∀ (a : B) (w : W), + rho (a • w) = S.modParameter a • rho w) + (hrho_ker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hparameter_sq : S.parameter * S.parameter = 0) + (b : Module.Basis (Fin (r + 1)) K V) (a : B) : + ∃ (Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) B) + (GammaK : Matrix (Fin (r + 1)) (Fin (r + 1)) K), + Gamma.map S.modParameter = GammaK.map (algebraMap K Abar) ∧ + ∀ i, + a • liftedBasisVector rho hrho b i = + (∑ j, liftedSourceActionMatrix S b + (leftMultiplicationEnd (K := K) (V := V) + (S.modParameter a)) i j • + liftedBasisVector rho hrho b j) + + S.parameter • + (∑ j, Gamma i j • liftedBasisVector rho hrho b j) := by + classical + let A := liftedSourceActionMatrix S b + (leftMultiplicationEnd (K := K) (V := V) (S.modParameter a)) + let error : Fin (r + 1) → W := fun i ↦ + a • liftedBasisVector rho hrho b i - + ∑ j, A i j • liftedBasisVector rho hrho b j + have herror : ∀ i, rho (error i) = 0 := by + intro i + rw [show rho (error i) = + rho (a • liftedBasisVector rho hrho b i) - + rho (∑ j, A i j • liftedBasisVector rho hrho b j) by + simp [error]] + rw [hrho_action, rho_liftedBasisVector] + simp_rw [map_sum, hrho_action, rho_liftedBasisVector] + have hAmap := liftedSourceActionMatrix_map S b + (leftMultiplicationEnd (K := K) (V := V) (S.modParameter a)) + have hentry : ∀ i j, S.modParameter (A i j) = + sourceActionCoefficients (Abar := Abar) b + (leftMultiplicationEnd (K := K) (V := V) + (S.modParameter a)) i j := by + intro p q + exact congrArg (fun M ↦ M p q) hAmap + simp_rw [hentry] + rw [sum_sourceActionCoefficients_smul] + simp + have herror_range : ∀ i, error i ∈ + AddMonoidHom.range (parameterAct (W := W) S.parameter) := by + intro i + rw [← hrho_ker] + exact AddMonoidHom.mem_ker.mpr (herror i) + choose u hu using herror_range + let Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) B := fun i j ↦ + zeroPreservingLift S + (algebraMap K Abar (b.repr (rho (u i)) j)) + have hresidual : ∀ i, + rho (u i - ∑ j, Gamma i j • liftedBasisVector rho hrho b j) = 0 := by + intro i + rw [map_sub, map_sum] + simp_rw [hrho_action, rho_liftedBasisVector] + have hGamma : ∀ j, S.modParameter (Gamma i j) = + algebraMap K Abar (b.repr (rho (u i)) j) := by + intro j + exact modParameter_zeroPreservingLift S _ + simp_rw [hGamma, IsScalarTower.algebraMap_smul] + rw [b.sum_repr, sub_self] + have hresidual_range : ∀ i, + u i - ∑ j, Gamma i j • liftedBasisVector rho hrho b j ∈ + AddMonoidHom.range (parameterAct (W := W) S.parameter) := by + intro i + rw [← hrho_ker] + exact AddMonoidHom.mem_ker.mpr (hresidual i) + choose v hv using hresidual_range + refine ⟨Gamma, (fun i j ↦ b.repr (rho (u i)) j), ?_, ?_⟩ + · ext i j + exact modParameter_zeroPreservingLift S _ + intro i + have hu_i : S.parameter • u i = error i := hu i + have hv_i : S.parameter • v i = + u i - ∑ j, Gamma i j • liftedBasisVector rho hrho b j := hv i + have hkill : S.parameter • + (u i - ∑ j, Gamma i j • liftedBasisVector rho hrho b j) = 0 := by + calc + S.parameter • + (u i - ∑ j, Gamma i j • liftedBasisVector rho hrho b j) = + S.parameter • (S.parameter • v i) := by rw [hv_i] + _ = (S.parameter * S.parameter) • v i := by + exact (mul_smul S.parameter S.parameter (v i)).symm + _ = 0 := by rw [hparameter_sq, zero_smul] + have hcu : S.parameter • u i = + S.parameter • + (∑ j, Gamma i j • liftedBasisVector rho hrho b j) := by + rw [smul_sub] at hkill + exact sub_eq_zero.mp hkill + have herr : error i = + S.parameter • + (∑ j, Gamma i j • liftedBasisVector rho hrho b j) := + hu_i.symm.trans hcu + calc + a • liftedBasisVector rho hrho b i = + (∑ j, A i j • liftedBasisVector rho hrho b j) + error i := by + dsimp [error] + abel + _ = (∑ j, A i j • liftedBasisVector rho hrho b j) + + S.parameter • + (∑ j, Gamma i j • liftedBasisVector rho hrho b j) := by + rw [herr] + +/-- Compatibility form retaining only the source equation. The stronger +producer also supplies coefficient-field reductions of every correction. -/ +theorem exists_firstOrderSourceActionMatrix + (S : LeftPrincipalParameterReduction (B := B) (Abar := Abar)) + (rho : W →+ V) (hrho : Function.Surjective rho) + (hrho_action : ∀ (a : B) (w : W), + rho (a • w) = S.modParameter a • rho w) + (hrho_ker : AddMonoidHom.ker rho = + AddMonoidHom.range (parameterAct (W := W) S.parameter)) + (hparameter_sq : S.parameter * S.parameter = 0) + (b : Module.Basis (Fin (r + 1)) K V) (a : B) : + ∃ Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) B, + ∀ i, + a • liftedBasisVector rho hrho b i = + (∑ j, liftedSourceActionMatrix S b + (leftMultiplicationEnd (K := K) (V := V) + (S.modParameter a)) i j • + liftedBasisVector rho hrho b j) + + S.parameter • + (∑ j, Gamma i j • liftedBasisVector rho hrho b j) := by + obtain ⟨Gamma, _, _, heq⟩ := + exists_firstOrderSourceActionMatrix_over_coefficientField + S rho hrho hrho_action hrho_ker hparameter_sq b a + exact ⟨Gamma, heq⟩ + + +end AbstractSourceEquation + +section LocalizedTwoBlockProducer + +variable {k R B N G : Type u} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] +variable [IsLocalRing (Localization S)] + +local notation "Wₗ" => LocalizedDeformationModule D S +local notation "A₀" => Localization S +local notation "𝔪" => IsLocalRing.maximalIdeal A₀ +local notation "C₂" => LocalizedTwoBlockRing D S + +/-- The doubled power acts trivially because it is contained in either one of +its two equal factors, and that factor already annihilates the module. -/ +theorem localizedDoubledPower_le_annihilator + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) : + localizedDoubledPower S q ≤ + Module.annihilator A₀ (LocalizedModule S G) := by + exact Ideal.mul_le_left.trans hpow + +/-- The canonical quotient-ring module structure on the actual localized +special fibre. It is kept as an explicit definition because its proof +depends on the chosen annihilating power. -/ +noncomputable def localizedDoubledPowerQuotientModule + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) : + Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := by + apply Module.IsTorsionBySet.module + intro w a + exact Module.mem_annihilator.mp + (localizedDoubledPower_le_annihilator S q hpow a.property) w + +/-- The actual localized specialization, with codomain carrying the canonical +doubled-power quotient action. -/ +def localizedDoubledPowerModuleSpecialization + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) : + Wₗ →+ LocalizedModule S G := + localizedSpecialization D S + +theorem localizedDoubledPowerModuleSpecialization_surjective + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) : + Function.Surjective + (localizedDoubledPowerModuleSpecialization D S q hpow) := + localizedSpecialization_surjective D S + +/-- Full action compatibility after both honest quotient descents. The left +side is the descended noncommutative two-block action; the right side is the +canonical doubled-power quotient action on the actual localized special +fibre. -/ +theorem localizedDoubledPowerModuleSpecialization_action + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) + (a : C₂ q) (w : Wₗ) : + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + localizedDoubledPowerQuotientModule S q hpow + localizedDoubledPowerModuleSpecialization D S q hpow + (localizedTwoBlockAction D S q hpow a w) = + localizedTwoBlockSpecialization D S q a • + localizedDoubledPowerModuleSpecialization D S q hpow w := by + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + localizedDoubledPowerQuotientModule S q hpow + induction a using Quotient.inductionOn' with + | _ z => + change localizedSpecialization D S (z • w) = + Ideal.Quotient.mk (localizedDoubledPower S q) + (SquareZeroLocalizedRing.localizedOppositeSpecialization D S z) • + localizedSpecialization D S w + rw [localizedSpecialization_smul] + rfl + +/-- The specialization kernel is still exactly the image of the actual +localized parameter action. -/ +theorem localizedDoubledPowerModuleSpecialization_ker + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) : + AddMonoidHom.ker + (localizedDoubledPowerModuleSpecialization D S q hpow) = + AddMonoidHom.range (localizedCAct D S) := + localizedSpecialization_ker_eq_range D S + +/-- A source-row linear combination using the actual descended two-block +action. -/ +def localizedSourceLinearCombination + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) + {r : ℕ} + (M : Matrix (Fin (r + 1)) (Fin (r + 1)) (C₂ q)) + (beta : Fin (r + 1) → Wₗ) (i : Fin (r + 1)) : Wₗ := + ∑ j, localizedTwoBlockAction D S q hpow (M i j) (beta j) + +/-- The literal source-row first-order action equation for one operator. All +actions in this predicate are the actual localized two-block actions. -/ +def LocalizedFirstOrderSourceActionEquation + {K : Type u} [Field K] + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) + [Algebra K (A₀ ⧸ localizedDoubledPower S q)] + [Module (A₀ ⧸ localizedDoubledPower S q) (LocalizedModule S G)] + [Module K (LocalizedModule S G)] + [IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G)] + {r : ℕ} + (P : LeftPrincipalParameterReduction + (B := C₂ q) (Abar := A₀ ⧸ localizedDoubledPower S q)) + (b : Module.Basis (Fin (r + 1)) K (LocalizedModule S G)) + (a : C₂ q) + (Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) (C₂ q)) : Prop := + ∀ i, + localizedTwoBlockAction D S q hpow a + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b i) = + localizedSourceLinearCombination D S q hpow + (liftedSourceActionMatrix P b + (leftMultiplicationEnd (K := K) + (V := LocalizedModule S G) (P.modParameter a))) + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i + + localizedTwoBlockAction D S q hpow P.parameter + (localizedSourceLinearCombination D S q hpow Gamma + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i) + +/-- The concrete first-order action-equation producer. + +For an actual element of the localized two-block ring and an actual basis of +the doubled-power special fibre, this theorem constructs the source-row +matrix `Gamma` and proves the lifted basis-vector equations. The same fixed +`liftedBasisVector` definition is used for every operator, so applying the +theorem to `x` and `y` produces `Gamma` and `Theta` on one common lifted basis. +-/ +theorem exists_localizedFirstOrderSourceActionMatrix + {K : Type u} [Field K] + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ (LocalizedModule S G)) + [Algebra K (A₀ ⧸ localizedDoubledPower S q)] + (P : LeftPrincipalParameterReduction + (B := C₂ q) (Abar := A₀ ⧸ localizedDoubledPower S q)) + (hPmod : P.modParameter = localizedTwoBlockSpecialization D S q) + (hPparameter : P.parameter = + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) + (a : C₂ q) : + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + localizedDoubledPowerQuotientModule S q hpow + letI : Module K (LocalizedModule S G) := + Module.compHom _ (algebraMap K (A₀ ⧸ localizedDoubledPower S q)) + letI : IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + ∀ {r : ℕ} (b : Module.Basis (Fin (r + 1)) K (LocalizedModule S G)), + ∃ Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) (C₂ q), + ∀ i, + localizedTwoBlockAction D S q hpow a + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b i) = + localizedSourceLinearCombination D S q hpow + (liftedSourceActionMatrix P b + (leftMultiplicationEnd (K := K) + (V := LocalizedModule S G) + (P.modParameter a))) + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i + + localizedTwoBlockAction D S q hpow P.parameter + (localizedSourceLinearCombination D S q hpow Gamma + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i) := by + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + localizedDoubledPowerQuotientModule S q hpow + letI : Module K (LocalizedModule S G) := + Module.compHom _ (algebraMap K (A₀ ⧸ localizedDoubledPower S q)) + letI : IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S G) := + IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + letI : Module (C₂ q) Wₗ := localizedTwoBlockModule D S q hpow + intro r b + have haction : ∀ (z : C₂ q) (w : Wₗ), + localizedDoubledPowerModuleSpecialization D S q hpow (z • w) = + P.modParameter z • + localizedDoubledPowerModuleSpecialization D S q hpow w := by + intro z w + rw [hPmod] + exact localizedDoubledPowerModuleSpecialization_action D S q hpow z w + have hparameterAct : + parameterAct (W := Wₗ) P.parameter = localizedCAct D S := by + ext w + change P.parameter • w = localizedCAct D S w + rw [hPparameter] + exact localizedTwoBlock_parameter_smul D S q hpow w + have hker : AddMonoidHom.ker + (localizedDoubledPowerModuleSpecialization D S q hpow) = + AddMonoidHom.range (parameterAct (W := Wₗ) P.parameter) := by + rw [hparameterAct] + exact localizedDoubledPowerModuleSpecialization_ker D S q hpow + have hsq : P.parameter * P.parameter = 0 := by + rw [hPparameter] + have h := localizedTwoBlock_parameter_sq D S q + rw [pow_two] at h + exact h + have hresult := exists_firstOrderSourceActionMatrix P + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective D S q hpow) + haction hker hsq b a + simp only [localizedSourceLinearCombination] + exact hresult + +end LocalizedTwoBlockProducer + +section ConcreteOrderReesProducer + +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotientTwoJet +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +variable (k : Type u) [Field k] +variable {n : ℕ} +variable (I : RightIdeal (PresentedWeyl k n)) +variable (S : Submonoid (SymbolRing k n)) + +local notation "D" => filteredQuotientTwoJetTraceData k I +local notation "A₀" => Localization S +local notation "𝔪" => IsLocalRing.maximalIdeal A₀ +local notation "Wₗ" => LocalizedDeformationModule D S +local notation "C₂" => LocalizedTwoBlockRing D S + +variable [OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) S)] +variable [IsLocalRing (Localization S)] + +/-- Concrete order-Rees specialization of the action-equation producer. + +There is no supplied parameter-reduction hypothesis here: the exact +left-principal reduction is the previously proved concrete two-block +specialization. Thus the returned first-order matrix belongs to the actual +localized order-Rees two-block ring and its equation uses the actual +localized deformation module action. -/ +theorem exists_concreteLocalizedFirstOrderSourceActionMatrix + {K : Type u} [Field K] + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ + (LocalizedModule S (OrderAssociatedGradedModule k I))) + [Algebra K (A₀ ⧸ localizedDoubledPower S q)] + (a : C₂ q) : + let P := concreteLeftPrincipalParameterReduction k I S q + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + localizedDoubledPowerQuotientModule S q hpow + letI : Module K + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + Module.compHom _ (algebraMap K (A₀ ⧸ localizedDoubledPower S q)) + letI : IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + ∀ {r : ℕ} + (b : Module.Basis (Fin (r + 1)) K + (LocalizedModule S (OrderAssociatedGradedModule k I))), + ∃ Gamma : Matrix (Fin (r + 1)) (Fin (r + 1)) (C₂ q), + ∀ i, + localizedTwoBlockAction D S q hpow a + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b i) = + localizedSourceLinearCombination D S q hpow + (liftedSourceActionMatrix P b + (leftMultiplicationEnd (K := K) + (V := LocalizedModule S + (OrderAssociatedGradedModule k I)) + (P.modParameter a))) + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i + + localizedTwoBlockAction D S q hpow P.parameter + (localizedSourceLinearCombination D S q hpow Gamma + (liftedBasisVector + (localizedDoubledPowerModuleSpecialization D S q hpow) + (localizedDoubledPowerModuleSpecialization_surjective + D S q hpow) b) i) := by + exact exists_localizedFirstOrderSourceActionMatrix D S q hpow + (concreteLeftPrincipalParameterReduction k I S q) rfl rfl a + +/-- Simultaneous concrete production of the source's `Gamma` and `Theta`. +Both equations use the same definitional choice of lifted basis vectors; no +second, independently chosen lift of the basis occurs. -/ +theorem exists_concreteLocalizedGammaTheta + {K : Type u} [Field K] + (q : ℕ) + (hpow : 𝔪 ^ q ≤ Module.annihilator A₀ + (LocalizedModule S (OrderAssociatedGradedModule k I))) + [Algebra K (A₀ ⧸ localizedDoubledPower S q)] + (x y : C₂ q) : + let P := concreteLeftPrincipalParameterReduction k I S q + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + localizedDoubledPowerQuotientModule S q hpow + letI : Module K + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + Module.compHom _ (algebraMap K (A₀ ⧸ localizedDoubledPower S q)) + letI : IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + ∀ {r : ℕ} + (b : Module.Basis (Fin (r + 1)) K + (LocalizedModule S (OrderAssociatedGradedModule k I))), + ∃ (Gamma Theta : Matrix (Fin (r + 1)) (Fin (r + 1)) (C₂ q)), + LocalizedFirstOrderSourceActionEquation D S q hpow P b x Gamma ∧ + LocalizedFirstOrderSourceActionEquation D S q hpow P b y Theta := by + dsimp only + let P := concreteLeftPrincipalParameterReduction k I S q + letI : Module (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + localizedDoubledPowerQuotientModule S q hpow + letI : Module K + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + Module.compHom _ (algebraMap K (A₀ ⧸ localizedDoubledPower S q)) + letI : IsScalarTower K (A₀ ⧸ localizedDoubledPower S q) + (LocalizedModule S (OrderAssociatedGradedModule k I)) := + IsScalarTower.of_algebraMap_smul fun _ _ ↦ rfl + intro r b + obtain ⟨Gamma, hGamma⟩ := + (exists_concreteLocalizedFirstOrderSourceActionMatrix + k I S q hpow x) b + obtain ⟨Theta, hTheta⟩ := + (exists_concreteLocalizedFirstOrderSourceActionMatrix + k I S q hpow y) b + exact ⟨Gamma, Theta, hGamma, hTheta⟩ + + +end ConcreteOrderReesProducer + +end + +end Stafford38.Characteristic.ConcreteInducedZAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteLocalizedTwoBlockSpecialFibre.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteLocalizedTwoBlockSpecialFibre.lean new file mode 100644 index 0000000000..6095f28113 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteLocalizedTwoBlockSpecialFibre.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedOrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent + +/-! +# The concrete localized two-block special fibre + +For the localized opposite order-Rees two-jet, the principal specialization +kernel theorem applies to the actual `RightReesArtinianAdapter` data. After +the two-block quotient, the kernel is therefore the two-sided ideal generated +by the parameter class. Quotienting by that ideal gives a ring equivalence +with the commutative doubled-power quotient. + +No Artinianness, module action, adapted basis, or equation-(3.3) input is used. +-/ + +namespace Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre + +open Stafford38.Characteristic +open Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicLocalizedOrderReesTwoJetSpecializationKernel +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} +variable (I : RightIdeal (PresentedWeyl k n)) +variable (S : Submonoid (SymbolRing k n)) +variable [OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) S)] +variable [IsLocalRing (Localization S)] + +private abbrev concreteData := filteredQuotientTwoJetTraceData k I + +local notation "D" => concreteData k I +local notation "Cₗ" => + OreLocalization (OppositeDenominators D S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ) +local notation "A₀" => Localization S + +/-- The concrete localized two-block parameter class. -/ +def concreteLocalizedTwoBlockParameter (q : ℕ) : + LocalizedTwoBlockRing D S q := + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k))) + +/-- The two-sided ideal generated by the parameter class. -/ +def concreteLocalizedTwoBlockParameterIdeal (q : ℕ) : + TwoSidedIdeal (LocalizedTwoBlockRing D S q) := + TwoSidedIdeal.span {concreteLocalizedTwoBlockParameter k I S q} + +/-- The actual order-Rees localized principal-kernel theorem, instantiated in +the notation consumed by the abstract two-block descent. -/ +theorem concreteLocalizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + (q : ℕ) (z : LocalizedTwoBlockRing D S q) : + localizedTwoBlockSpecialization D S q z = 0 ↔ + ∃ y : LocalizedTwoBlockRing D S q, + concreteLocalizedTwoBlockParameter k I S q * y = z := by + exact localizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + D S q + (localizedOrderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + k I S) z + +/-- In the concrete two-jet, the specialization kernel is exactly the +two-sided ideal generated by the quotient parameter. -/ +theorem concreteLocalizedTwoBlockParameterIdeal_eq_ker (q : ℕ) : + concreteLocalizedTwoBlockParameterIdeal k I S q = + TwoSidedIdeal.ker (localizedTwoBlockSpecialization D S q) := by + apply le_antisymm + · intro z hz + change z ∈ TwoSidedIdeal.span + {concreteLocalizedTwoBlockParameter k I S q} at hz + rw [TwoSidedIdeal.mem_span_iff] at hz + exact hz (TwoSidedIdeal.ker (localizedTwoBlockSpecialization D S q)) (by + intro c hc + rcases hc with rfl + apply (TwoSidedIdeal.mem_ker + (localizedTwoBlockSpecialization D S q)).2 + change localizedTwoBlockSpecialization D S q + (concreteLocalizedTwoBlockParameter k I S q) = 0 + exact + (concreteLocalizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + k I S q (concreteLocalizedTwoBlockParameter k I S q)).2 + ⟨1, mul_one _⟩) + · intro z hz + have hz0 : localizedTwoBlockSpecialization D S q z = 0 := + (TwoSidedIdeal.mem_ker + (localizedTwoBlockSpecialization D S q)).1 hz + obtain ⟨y, rfl⟩ := + (concreteLocalizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + k I S q z).mp hz0 + exact (concreteLocalizedTwoBlockParameterIdeal k I S q).mul_mem_right + _ _ (TwoSidedIdeal.subset_span (Set.mem_singleton _)) + +/-- The literal quotient of the localized two-block ring by its parameter +class. -/ +abbrev ConcreteLocalizedTwoBlockSpecialFibreRing (q : ℕ) := + (concreteLocalizedTwoBlockParameterIdeal k I S q).ringCon.Quotient + +/-- Specialization descended to the quotient by the parameter class. -/ +def concreteLocalizedTwoBlockSpecialFibreHom (q : ℕ) : + ConcreteLocalizedTwoBlockSpecialFibreRing k I S q →+* + (Localization S) ⧸ localizedDoubledPower S q := + quotientRingHom (concreteLocalizedTwoBlockParameterIdeal k I S q) + (localizedTwoBlockSpecialization D S q) (by + intro z hz + exact (TwoSidedIdeal.mem_ker + (localizedTwoBlockSpecialization D S q)).1 + ((concreteLocalizedTwoBlockParameterIdeal_eq_ker k I S q) ▸ hz)) + +@[simp] +theorem concreteLocalizedTwoBlockSpecialFibreHom_mk + (q : ℕ) (z : LocalizedTwoBlockRing D S q) : + concreteLocalizedTwoBlockSpecialFibreHom k I S q + ((concreteLocalizedTwoBlockParameterIdeal k I S q).ringCon.mk' z) = + localizedTwoBlockSpecialization D S q z := by + rfl + +theorem concreteLocalizedTwoBlockSpecialFibreHom_injective (q : ℕ) : + Function.Injective (concreteLocalizedTwoBlockSpecialFibreHom k I S q) := by + intro x y hxy + induction x using Quotient.inductionOn' with + | _ a => + induction y using Quotient.inductionOn' with + | _ b => + apply Quotient.sound' + apply (concreteLocalizedTwoBlockParameterIdeal k I S q).rel_iff a b |>.2 + rw [concreteLocalizedTwoBlockParameterIdeal_eq_ker] + apply (TwoSidedIdeal.mem_ker + (localizedTwoBlockSpecialization D S q)).2 + rw [map_sub, sub_eq_zero] + exact hxy + +theorem concreteLocalizedTwoBlockSpecialFibreHom_surjective (q : ℕ) : + Function.Surjective + (concreteLocalizedTwoBlockSpecialFibreHom k I S q) := by + intro z + obtain ⟨y, hy⟩ := localizedTwoBlockSpecialization_surjective D S q z + exact ⟨(concreteLocalizedTwoBlockParameterIdeal k I S q).ringCon.mk' y, hy⟩ + +/-- The quotient ring modulo the concrete quotient parameter is exactly the +doubled-power commutative quotient. -/ +def concreteLocalizedTwoBlockSpecialFibreRingEquiv (q : ℕ) : + ConcreteLocalizedTwoBlockSpecialFibreRing k I S q ≃+* + (Localization S) ⧸ localizedDoubledPower S q := + RingEquiv.ofBijective (concreteLocalizedTwoBlockSpecialFibreHom k I S q) + ⟨concreteLocalizedTwoBlockSpecialFibreHom_injective k I S q, + concreteLocalizedTwoBlockSpecialFibreHom_surjective k I S q⟩ + +@[simp] +theorem concreteLocalizedTwoBlockSpecialFibreRingEquiv_mk + (q : ℕ) (z : LocalizedTwoBlockRing D S q) : + concreteLocalizedTwoBlockSpecialFibreRingEquiv k I S q + ((concreteLocalizedTwoBlockParameterIdeal k I S q).ringCon.mk' z) = + localizedTwoBlockSpecialization D S q z := by + rfl + + +end + +end Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteSquareZeroTraceData.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteSquareZeroTraceData.lean new file mode 100644 index 0000000000..a5de9c7906 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ConcreteSquareZeroTraceData.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientTwoJet +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetBracket +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroTraceData + +/-! +# Concrete square-zero trace data for a filtered Weyl quotient + +This file assembles the order-Rees two-jet ring and the filtered quotient +two-jet module into the abstract right-module interface used by the trace +argument. The recorded bracket is the negative standard Poisson bracket, +as forced by the convention `[x,p] = -1`. + +No localization, finite-length trace theorem, or radical involutivity theorem +is asserted here. +-/ + +namespace Stafford38.CharacteristicConcreteSquareZeroTraceData + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotientTwoJet +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.CharacteristicOrderReesTwoJetBracket +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.EulerSurjectivity +open Stafford38.WeylFilteredCommutator +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The sign-correct first-order bracket as a curried bilinear map. -/ +def negativePoissonBracketLinear : + SymbolRing k n →ₗ[k] SymbolRing k n →ₗ[k] SymbolRing k n where + toFun f := + { toFun := fun g => -poissonBracket f g + map_add' := by + intro g h + change -poissonBracket f (g + h) = + -poissonBracket f g + -poissonBracket f h + rw [poissonBracket_add_right, neg_add] + map_smul' := by + intro c g + change -poissonBracket f (c • g) = + c • (-poissonBracket f g) + rw [poissonBracket_smul_right, smul_neg] } + map_add' := by + intro f g + apply LinearMap.ext + intro h + change -poissonBracket (f + g) h = + -poissonBracket f h + -poissonBracket g h + rw [poissonBracket_add_left, neg_add] + map_smul' := by + intro c f + apply LinearMap.ext + intro g + change -poissonBracket (c • f) g = + c • (-poissonBracket f g) + rw [poissonBracket_smul_left, smul_neg] + +@[simp] theorem negativePoissonBracketLinear_apply + (f g : SymbolRing k n) : + negativePoissonBracketLinear (n := n) k f g = + -poissonBracket f g := + rfl + +/-- The two-jet action commutes with the original coefficient-field action. -/ +def filteredQuotientTwoJetSMulCommClass + (I : RightIdeal (PresentedWeyl k n)) : + SMulCommClass k (OrderReesTwoJet (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) where + smul_comm c b m := by + change c • quotientOrderReesTwoJetAction k I b m = + quotientOrderReesTwoJetAction k I b (c • m) + exact ((quotientOrderReesTwoJetAction k I b).map_smul c m).symm + +noncomputable instance filteredQuotientTwoJetSMulCommClassInstance + (I : RightIdeal (PresentedWeyl k n)) : + SMulCommClass k (OrderReesTwoJet (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + filteredQuotientTwoJetSMulCommClass k I + +/-- The concrete order-Rees two-jet deformation of the associated graded +module of `A/I`, packaged with its negative-Poisson first-order bracket. -/ +def filteredQuotientTwoJetTraceData + (I : RightIdeal (PresentedWeyl k n)) : + RightSquareZeroTraceData k (SymbolRing k n) + (OrderReesTwoJet (n := n) k) + (FilteredQuotientTwoJet k I) + (OrderAssociatedGradedModule k I) where + c := orderReesTwoJetParameter (n := n) k + c_center := orderReesTwoJetParameter_mem_center (n := n) k + c_sq := orderReesTwoJetParameter_sq (n := n) k + pi := orderReesTwoJetSpecialization (n := n) k + pi_surjective := orderReesTwoJetSpecialization_surjective (n := n) k + pi_c := orderReesTwoJetSpecialization_parameter (n := n) k + cAct := quotientOrderReesTwoJetCAct k I + cAct_apply := quotientOrderReesTwoJetCAct_apply k I + c_exact := quotientOrderReesTwoJetCAct_ker_eq_range k I + rho := filteredQuotientTwoJetRho k I + rho_surjective := filteredQuotientTwoJetRho_surjective k I + rho_ker := filteredQuotientTwoJetRho_ker_eq_range_cAct k I + rho_action := filteredQuotientTwoJetRho_action_compatibility k I + bracket := negativePoissonBracketLinear (n := n) k + commutator_factor := by + intro a b + obtain ⟨z, hz, hpi⟩ := exists_twoJet_commutatorQuotient k a b + exact ⟨z, hz, by simpa using hpi⟩ + +@[simp] theorem filteredQuotientTwoJetTraceData_bracket + (I : RightIdeal (PresentedWeyl k n)) (f g : SymbolRing k n) : + (filteredQuotientTwoJetTraceData k I).bracket f g = + -poissonBracket f g := + rfl + + +end + +end Stafford38.CharacteristicConcreteSquareZeroTraceData diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/EmptySupportVanishing.lean b/LeanPool/Stafford38/Stafford38/Characteristic/EmptySupportVanishing.lean new file mode 100644 index 0000000000..d195b05b41 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/EmptySupportVanishing.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSupport +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredVanishing + +/-! +# Empty order-characteristic support forces quotient vanishing + +The global additive equivalence between the cyclic symbol quotient and the +external direct sum of the actual filtered quotient pieces is enough for +vanishing. No action of the symbol ring on that direct sum is transported or +used here. +-/ + +namespace Stafford38.CharacteristicEmptySupportVanishing + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicFilteredQuotientSupport +open Stafford38.CharacteristicFilteredVanishing +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- Empty order-characteristic support makes every actual associated-graded +piece of the induced quotient filtration subsingleton. The argument uses +only the global additive equivalence with the cyclic symbol quotient. -/ +theorem all_graded_subsingleton_of_orderCharacteristicSupport_eq_empty + (I : RightIdeal (PresentedWeyl k n)) + (hsupport : orderCharacteristicSupport k I = ∅) : + ∀ N, Subsingleton (QuotientOrderGradedPiece k I N) := by + have htop : orderInitialIdeal k I = ⊤ := + (orderCharacteristicSupport_eq_empty_iff k I).mp hsupport + letI : Subsingleton (OrderCharacteristicModule k I) := by + rw [Submodule.Quotient.subsingleton_iff] + exact htop + letI : Subsingleton (QuotientOrderAssociatedGraded k I) := + (quotientOrderAssociatedGradedAddEquivCharacteristic k I).toEquiv.subsingleton + intro N + exact ⟨fun q r => DirectSum.of_injective N (Subsingleton.elim + (DirectSum.of (fun M => QuotientOrderGradedPiece k I M) N q) + (DirectSum.of (fun M => QuotientOrderGradedPiece k I M) N r))⟩ + +/-- Empty order-characteristic support reflects through the actual associated +graded pieces to vanishing of the original right-module quotient. -/ +theorem rightQuotient_subsingleton_of_orderCharacteristicSupport_eq_empty + (I : RightIdeal (PresentedWeyl k n)) + (hsupport : orderCharacteristicSupport k I = ∅) : + Subsingleton (RightQuotient I) := + rightQuotient_subsingleton_of_all_graded_subsingleton k I + (all_graded_subsingleton_of_orderCharacteristicSupport_eq_empty k I hsupport) + +/-- Vanishing of the actual quotient also forces every filtered graded piece +to vanish. -/ +theorem all_graded_subsingleton_of_rightQuotient_subsingleton + (I : RightIdeal (PresentedWeyl k n)) + (hquotient : Subsingleton (RightQuotient I)) : + ∀ N, Subsingleton (QuotientOrderGradedPiece k I N) := by + letI : Subsingleton (RightQuotient I) := hquotient + letI : Subsingleton (FilteredRightQuotient k I) := + (filteredRightQuotientEquivRightQuotient k I).toEquiv.subsingleton + intro N + constructor + intro q r + refine Submodule.Quotient.induction_on _ q ?_ + intro a + refine Submodule.Quotient.induction_on _ r ?_ + intro b + exact congrArg Submodule.Quotient.mk + (Subtype.ext (Subsingleton.elim a.1 b.1)) + +/-- For the concrete order filtration, the initial ideal is the unit ideal +exactly when the original right-module quotient vanishes. -/ +theorem orderInitialIdeal_eq_top_iff_rightQuotient_subsingleton + (I : RightIdeal (PresentedWeyl k n)) : + orderInitialIdeal k I = ⊤ ↔ Subsingleton (RightQuotient I) := by + constructor + · intro htop + apply rightQuotient_subsingleton_of_orderCharacteristicSupport_eq_empty k I + exact (orderCharacteristicSupport_eq_empty_iff k I).mpr htop + · intro hquotient + letI : ∀ N, Subsingleton (QuotientOrderGradedPiece k I N) := + all_graded_subsingleton_of_rightQuotient_subsingleton k I hquotient + letI : Subsingleton (QuotientOrderAssociatedGraded k I) := by + infer_instance + letI : Subsingleton (OrderCharacteristicModule k I) := + (Equiv.subsingleton_congr + (quotientOrderAssociatedGradedAddEquivCharacteristic k I).toEquiv).mp + (by infer_instance) + exact (Submodule.Quotient.subsingleton_iff).mp (by infer_instance) + +/-- Clean support formulation of the same vanishing criterion. -/ +theorem orderCharacteristicSupport_eq_empty_iff_rightQuotient_subsingleton + (I : RightIdeal (PresentedWeyl k n)) : + orderCharacteristicSupport k I = ∅ ↔ Subsingleton (RightQuotient I) := by + rw [orderCharacteristicSupport_eq_empty_iff, + orderInitialIdeal_eq_top_iff_rightQuotient_subsingleton] + + +end + +end Stafford38.CharacteristicEmptySupportVanishing diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupport.lean b/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupport.lean new file mode 100644 index 0000000000..642436227e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupport.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupport + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic + +export AlgebraicAnalysis (endomorphism_kernel_support_subset_cokernel_support) + +end Stafford38.Characteristic diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupportOverBase.lean b/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupportOverBase.lean new file mode 100644 index 0000000000..190bf7fcd4 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/EndomorphismKernelSupportOverBase.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupport + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic + +export AlgebraicAnalysis (endomorphism_kernel_support_subset_cokernel_support_over_base) + +end Stafford38.Characteristic diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotient.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotient.lean new file mode 100644 index 0000000000..46961f1e63 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotient.lean @@ -0,0 +1,435 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdeal +import LeanPool.Stafford38.Stafford38.Weyl.AssociatedGraded + +/-! +# Differential-order filtration on a right-ideal quotient + +This file constructs the filtration induced on the actual additive quotient by +a right ideal and identifies each associated graded piece with homogeneous +symbols modulo the principal components of the filtered ideal. Thus the +degreewise object is derived from `A / I`; it is not the cyclic +`SymbolRing / orderInitialIdeal` model. + +The remaining global step is to assemble these degreewise equivalences into a +graded `SymbolRing`-module equivalence and identify its annihilator/support +with `orderInitialIdeal`. +-/ + +namespace Stafford38.CharacteristicFilteredQuotient + +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylLeadingSymbol + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] + +/-! +`PresentedWeyl` is a `RingQuot`, whose `AddCommMonoid` and `Ring` instances +are declared independently. The two induced `AddCommMonoid` structures on a +submodule of it are definitionally equal but not syntactically identical, and +since Lean 4.33 instance arguments are matched only up to instance +transparency. Mathlib's `Submodule.hasQuotient` expects the group-derived +shape, so without the two alignments below no quotient `↥p ⧸ q` of a +differential-order piece elaborates. Both are `rfl`, so nothing about the +`k`-module structure changes. +-/ + +local instance (priority := 10000) pieceAddCommMonoid {n : ℕ} + (p : Submodule k (PresentedWeyl k n)) : AddCommMonoid p := + AddCommGroup.toAddCommMonoid + +local instance (priority := 10000) pieceModule {n : ℕ} + (p : Submodule k (PresentedWeyl k n)) : Module k p := + Submodule.module p + +/-- A right ideal, regarded only as a `k`-linear subspace. Its carrier is +literally unchanged. -/ +def rightIdealKSubmodule {A : Type*} [Ring A] [Algebra k A] + (I : RightIdeal A) : Submodule k A where + carrier := I + zero_mem' := I.zero_mem + add_mem' := I.add_mem + smul_mem' c a ha := by + have h := I.smul_mem (MulOpposite.op (algebraMap k A c)) ha + rw [Algebra.smul_def, Algebra.commutes] + exact h + +@[simp] theorem mem_rightIdealKSubmodule {A : Type*} [Ring A] [Algebra k A] + (I : RightIdeal A) (a : A) : + a ∈ rightIdealKSubmodule k I ↔ a ∈ I := + Iff.rfl + +theorem rightIdealKSubmodule_eq_restrictScalars + {A : Type*} [Ring A] [Algebra k A] (I : RightIdeal A) : + rightIdealKSubmodule k I = I.restrictScalars k := by + ext a + rfl + +/-- The `k`-linear quotient used for the filtration is canonically the same +underlying quotient as the regular right-module quotient. -/ +def filteredRightQuotientEquivRightQuotient + {A : Type*} [Ring A] [Algebra k A] (I : RightIdeal A) : + (A ⧸ rightIdealKSubmodule k I) ≃ₗ[k] RightQuotient I := + Submodule.quotEquivOfEq _ _ (rightIdealKSubmodule_eq_restrictScalars k I) ≪≫ₗ + Submodule.Quotient.restrictScalarsEquiv k I + +variable {n : ℕ} + +/-- The additive quotient by the underlying `k`-subspace of a right ideal. -/ +abbrev FilteredRightQuotient (I : RightIdeal (PresentedWeyl k n)) := + PresentedWeyl k n ⧸ rightIdealKSubmodule k I + +/-- Global alignment for the actual filtered quotient. Lean 4.33 matches +instance arguments only up to instance transparency, and the default +`Submodule.Quotient.addCommMonoid` is not the additive monoid derived from the +quotient's `AddCommGroup`. Without this alignment the direct sum of the +pieces below inherits an additive monoid that `Submodule.hasQuotient` cannot +match, and `FilteredQuotientSpecialFibre` cannot state its quotient. This is +the same repair already made below for `QuotientOrderGradedPiece`. -/ +instance (priority := 10000) filteredRightQuotientAddCommMonoid + (I : RightIdeal (PresentedWeyl k n)) : + AddCommMonoid (FilteredRightQuotient k I) := + AddCommGroup.toAddCommMonoid + +instance (priority := 10000) filteredRightQuotientModule + (I : RightIdeal (PresentedWeyl k n)) : + Module k (FilteredRightQuotient k I) := + Submodule.Quotient.module _ + +/-- The image of the differential-order piece in the actual quotient. -/ +def quotientOrderPiece (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + Submodule k (FilteredRightQuotient k I) := + (presentedWeightPiece k (@orderWeight n) N).map + (rightIdealKSubmodule k I).mkQ + +/-- The image of the strict lower differential-order piece in the actual +quotient. -/ +def quotientOrderStrictLowerPiece (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + Submodule k (FilteredRightQuotient k I) := + (presentedStrictLowerPiece k orderWeight N).map + (rightIdealKSubmodule k I).mkQ + +theorem quotientOrderStrictLowerPiece_le + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + quotientOrderStrictLowerPiece k I N ≤ quotientOrderPiece k I N := + Submodule.map_mono (presentedStrictLowerPiece_le k orderWeight) + +/-- The degree-`N` associated graded piece of the filtration induced on the +actual quotient `A / I`. -/ +abbrev QuotientOrderGradedPiece + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) := + quotientOrderPiece k I N ⧸ + (quotientOrderStrictLowerPiece k I N).comap + (quotientOrderPiece k I N).subtype + +/-- The same global alignment for the actual graded pieces: they are the +components of `QuotientOrderAssociatedGraded`, whose `AddCommGroup` instance +needs the group-derived additive monoid on each component. -/ +instance (priority := 10000) quotientOrderGradedPieceAddCommMonoid + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + AddCommMonoid (QuotientOrderGradedPiece k I N) := + AddCommGroup.toAddCommMonoid + +instance (priority := 10000) quotientOrderGradedPieceModule + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + Module k (QuotientOrderGradedPiece k I N) := + Submodule.Quotient.module _ + +/-- Relations in the degree-`N` filtered algebra piece: an element is zero in +the quotient graded piece exactly when it lies in `I + F_{ ⟨z, z.property, rfl⟩) + +/-- The canonical map from a filtered algebra piece to the corresponding +graded piece of the actual quotient. -/ +def orderPieceToQuotientGraded + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + presentedWeightPiece k (@orderWeight n) N →ₗ[k] QuotientOrderGradedPiece k I N := + ((quotientOrderStrictLowerPiece k I N).comap + (quotientOrderPiece k I N).subtype).mkQ.comp + (orderPieceToQuotientPiece k I N) + +theorem orderPieceToQuotientGraded_surjective + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + Function.Surjective (orderPieceToQuotientGraded k I N) := by + intro q + refine Submodule.Quotient.induction_on _ q ?_ + rintro ⟨q, hq⟩ + obtain ⟨z, hz, rfl⟩ := hq + exact ⟨⟨z, hz⟩, rfl⟩ + +/-- Exact kernel computation for the filtered quotient map. -/ +theorem ker_orderPieceToQuotientGraded + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + LinearMap.ker (orderPieceToQuotientGraded k I N) = + orderQuotientRelation k I N := by + ext z + rw [LinearMap.mem_ker] + change Submodule.Quotient.mk + (⟨(rightIdealKSubmodule k I).mkQ z, + ⟨z, z.property, rfl⟩⟩ : quotientOrderPiece k I N) = 0 ↔ _ + rw [Submodule.Quotient.mk_eq_zero] + change (rightIdealKSubmodule k I).mkQ z ∈ + quotientOrderStrictLowerPiece k I N ↔ _ + change (z : PresentedWeyl k n) ∈ + (quotientOrderStrictLowerPiece k I N).comap + (rightIdealKSubmodule k I).mkQ ↔ _ + rw [quotientOrderStrictLowerPiece, Submodule.comap_map_mkQ] + rfl + +/-- The actual quotient graded piece is the filtered algebra piece modulo +`I + F_{ + principalComponentOnPiece k (@orderWeight n) N ii + Q) hpl + _ = principalComponentOnPiece k (@orderWeight n) N ii := add_zero _ + _ = principalComponentOnPiece k (@orderWeight n) N ⟨i, hiN⟩ := by + congr 1 + · rintro ⟨z, hzN, hzI, rfl⟩ + exact principalComponent_mem_orderSymbolRelation k I N z hzN hzI + +/-- Every exact degree-`N` relation of the actual quotient is one of the +generators used by the existing order initial ideal. -/ +theorem coe_mem_orderInitialGeneratorSet_of_mem_orderSymbolRelation + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) + (hP : P ∈ orderSymbolRelation k I N) : + (P : SymbolRing k n) ∈ orderInitialGeneratorSet k I := by + obtain ⟨z, hzN, hzI, hPz⟩ := + (mem_orderSymbolRelation_iff k I N P).mp hP + refine ⟨N, z, hzN, hzI, ?_⟩ + rw [hPz] + rfl + +theorem coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) + (hP : P ∈ orderSymbolRelation k I N) : + (P : SymbolRing k n) ∈ orderInitialIdeal k I := + Ideal.subset_span + (coe_mem_orderInitialGeneratorSet_of_mem_orderSymbolRelation k I N P hP) + + +end + +end Stafford38.CharacteristicFilteredQuotient diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientGraded.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientGraded.lean new file mode 100644 index 0000000000..c7e5466af2 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientGraded.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotient + +/-! +# The graded bridge for a filtered right-ideal quotient + +The degreewise equivalences of `FilteredQuotient` assemble into an external +direct-sum equivalence. The exact symbol relation in degree `N` is stable +under multiplication by a homogeneous symbol of degree `M`; transporting this +operator gives the actual quotient graded pieces homogeneous multiplication +maps compatible with Weyl multiplication. + +This file does not identify the direct sum with +`SymbolRing / orderInitialIdeal`. That final identification requires proving +that the degree-`N` part of the ideal generated by all initial symbols is +exactly `orderSymbolRelation k I N`. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientGraded + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylLeadingSymbol + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The external direct sum of the actual associated-graded pieces of `A/I`. -/ +abbrev QuotientOrderAssociatedGraded (I : RightIdeal (PresentedWeyl k n)) := + DirectSum ℕ (fun N => QuotientOrderGradedPiece k I N) + +/-- The external direct sum of homogeneous symbols modulo the exact relation +piece coming from the filtered quotient. -/ +abbrev OrderSymbolRelationGraded (I : RightIdeal (PresentedWeyl k n)) := + DirectSum ℕ (fun N => + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N ⧸ + orderSymbolRelation k I N) + +/-- The degreewise filtered-quotient equivalences assemble without adding any +unproved multiplication or support assertion. -/ +def quotientOrderAssociatedGradedEquivSymbols + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderAssociatedGraded k I ≃ₗ[k] OrderSymbolRelationGraded k I := + DFinsupp.mapRange.linearEquiv fun N => + quotientOrderGradedPieceEquivSymbols k I N + +/-- Right multiplication by a homogeneous symbol, with the resulting degree +recorded in the codomain. -/ +def homogeneousRightMul {N M : ℕ} + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) : + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N →ₗ[k] + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) (N + M) where + toFun Q := ⟨(Q : SymbolRing k n) * P, Q.property.mul P.property⟩ + map_add' Q R := by + apply Subtype.ext + exact add_mul (Q : SymbolRing k n) R P + map_smul' c Q := by + apply Subtype.ext + exact Algebra.smul_mul_assoc c (Q : SymbolRing k n) P + +@[simp] theorem coe_homogeneousRightMul {N M : ℕ} + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) + (Q : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) : + (homogeneousRightMul k P Q : SymbolRing k n) = Q * P := + rfl + +/-- The exact degree-`N` relation is closed under multiplication by every +degree-`M` homogeneous symbol. This is the load-bearing multiplication +compatibility: it uses right-ideal closure before passing to principal +symbols. -/ +theorem homogeneousRightMul_mem_orderSymbolRelation {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) + (Q : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) + (hQ : Q ∈ orderSymbolRelation k I N) : + homogeneousRightMul k P Q ∈ orderSymbolRelation k I (N + M) := by + obtain ⟨z, hzN, hzI, hQz⟩ := + (mem_orderSymbolRelation_iff k I N Q).mp hQ + obtain ⟨y, hy⟩ := + principalComponentOnPiece_surjective k (@orderWeight n) P + let zy : PresentedWeyl k n := z * (y : PresentedWeyl k n) + have hzyPiece : zy ∈ orderPiece k n (N + M) := + mul_mem_orderPiece k hzN y.property + have hzyI : zy ∈ I := by + exact I.smul_mem (MulOpposite.op (y : PresentedWeyl k n)) hzI + apply (mem_orderSymbolRelation_iff k I (N + M) + (homogeneousRightMul k P Q)).mpr + refine ⟨zy, hzyPiece, hzyI, ?_⟩ + apply Subtype.ext + change (Q : SymbolRing k n) * P = + presentedPrincipalComponent k (@orderWeight n) (N + M) zy + rw [presentedPrincipalComponent_mul_order k hzN y.property] + change (Q : SymbolRing k n) * P = + presentedPrincipalComponent k (@orderWeight n) N z * + (principalComponentOnPiece k (@orderWeight n) M y : SymbolRing k n) + have hQz' : (Q : SymbolRing k n) = + presentedPrincipalComponent k (@orderWeight n) N z := + congrArg Subtype.val hQz + have hy' : + (principalComponentOnPiece k (@orderWeight n) M y : SymbolRing k n) = P := + congrArg Subtype.val hy + rw [hQz', hy'] + +/-- A homogeneous symbol acts on the corresponding quotient of homogeneous +symbols because exact relation pieces are multiplicatively stable. -/ +def homogeneousSymbolAction {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) : + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N ⧸ + orderSymbolRelation k I N) →ₗ[k] + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) (N + M) ⧸ + orderSymbolRelation k I (N + M)) := + (orderSymbolRelation k I N).mapQ (orderSymbolRelation k I (N + M)) + (homogeneousRightMul k P) + (homogeneousRightMul_mem_orderSymbolRelation k I P) + +@[simp] theorem homogeneousSymbolAction_mk {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) + (Q : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) : + homogeneousSymbolAction k I P (Submodule.Quotient.mk Q) = + Submodule.Quotient.mk (homogeneousRightMul k P Q) := + rfl + +/-- Transport of homogeneous symbol multiplication to the actual +associated-graded pieces of the filtered quotient. -/ +def quotientOrderHomogeneousAction {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) : + QuotientOrderGradedPiece k I N →ₗ[k] + QuotientOrderGradedPiece k I (N + M) := + (quotientOrderGradedPieceEquivSymbols k I (N + M)).symm.toLinearMap.comp + ((homogeneousSymbolAction k I P).comp + (quotientOrderGradedPieceEquivSymbols k I N).toLinearMap) + +/-- The transported action commutes exactly with the degreewise symbol +equivalences. -/ +theorem quotientOrderHomogeneousAction_compatibility {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (P : MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M) + (q : QuotientOrderGradedPiece k I N) : + quotientOrderGradedPieceEquivSymbols k I (N + M) + (quotientOrderHomogeneousAction k I P q) = + homogeneousSymbolAction k I P + (quotientOrderGradedPieceEquivSymbols k I N q) := by + simp [quotientOrderHomogeneousAction] + +@[simp] theorem quotientOrderGradedPieceEquivSymbols_mk {N : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (z : orderPiece k n N) : + quotientOrderGradedPieceEquivSymbols k I N + (orderPieceToQuotientGraded k I N z) = + Submodule.Quotient.mk + (principalComponentOnPiece k (@orderWeight n) N z) := by + rw [quotientOrderGradedPieceEquivSymbols, LinearEquiv.trans_apply] + rw [← show quotientOrderGradedPieceEquivRelation k I N + (Submodule.Quotient.mk z) = orderPieceToQuotientGraded k I N z from rfl] + rw [LinearEquiv.symm_apply_apply] + rfl + +/-- On classes of filtered representatives, the transported homogeneous +operator is exactly multiplication in the Weyl algebra followed by passage to +the associated graded quotient. -/ +theorem quotientOrderHomogeneousAction_mk_mul {N M : ℕ} + (I : RightIdeal (PresentedWeyl k n)) + (z : orderPiece k n N) (y : orderPiece k n M) : + quotientOrderHomogeneousAction k I + (principalComponentOnPiece k (@orderWeight n) M y) + (orderPieceToQuotientGraded k I N z) = + orderPieceToQuotientGraded k I (N + M) + ⟨(z : PresentedWeyl k n) * y, + mul_mem_orderPiece k z.property y.property⟩ := by + apply (quotientOrderGradedPieceEquivSymbols k I (N + M)).injective + rw [quotientOrderHomogeneousAction_compatibility] + rw [quotientOrderGradedPieceEquivSymbols_mk, + quotientOrderGradedPieceEquivSymbols_mk, + homogeneousSymbolAction_mk] + congr 1 + apply Subtype.ext + exact (presentedPrincipalComponent_mul_order k z.property y.property).symm + +/-! +The remaining prerequisite for a global `SymbolRing`-module equivalence is +the homogeneous-piece equality + +`P ∈ orderSymbolRelation k I N ↔ + (P : SymbolRing k n) ∈ orderInitialIdeal k I`. + +The forward implication is already proved in `FilteredQuotient`. The reverse +implication requires decomposing arbitrary ideal multipliers into weighted +homogeneous components and combining the action above degree by degree. No +support or annihilator statement is made before that equality is available. +-/ + + +end + +end Stafford38.CharacteristicFilteredQuotientGraded diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientRees.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientRees.lean new file mode 100644 index 0000000000..1e96d4c737 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientRees.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Weyl.OrderRees +import Mathlib.Algebra.DirectSum.Module + +/-! +# The filtered quotient direct sum and associated-graded map + +The filtered quotient pieces assemble into a direct sum with a successor +shift. Quotienting each degree by the preceding piece gives the already +constructed associated graded module; here we define the global map, prove +that it kills the shift, and prove surjectivity. This file does not construct +the required right action of the order-Rees ring. Kernel equality and that +action are deliberately left as subsequent theorems. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientRees + +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +theorem quotientOrderPiece_mono + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} (hNM : N ≤ M) : + quotientOrderPiece k I N ≤ quotientOrderPiece k I M := by + exact Submodule.map_mono (presentedWeightPiece_mono k orderWeight hNM) + +theorem quotientOrderStrictLowerPiece_succ_eq + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + quotientOrderStrictLowerPiece k I (N + 1) = + quotientOrderPiece k I N := by + rfl + +/-- The filtered direct sum underlying the intended right Rees module. -/ +abbrev QuotientOrderReesModule + (I : RightIdeal (PresentedWeyl k n)) := + DirectSum ℕ (fun N => quotientOrderPiece k I N) + +/-- Inclusion of one quotient filtration piece into the next. -/ +def quotientOrderPieceSucc + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + quotientOrderPiece k I N →ₗ[k] quotientOrderPiece k I (N + 1) := + Submodule.inclusion (quotientOrderPiece_mono k I (Nat.le_succ N)) + +/-- The successor inclusion shift on the filtered quotient direct sum. -/ +def quotientOrderReesShift + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderReesModule k I →ₗ[k] QuotientOrderReesModule k I := + DirectSum.toModule k ℕ (QuotientOrderReesModule k I) fun N => + (DirectSum.lof k ℕ (fun M => quotientOrderPiece k I M) (N + 1)).comp + (quotientOrderPieceSucc k I N) + +@[simp] theorem quotientOrderReesShift_of + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (q : quotientOrderPiece k I N) : + quotientOrderReesShift k I + (DirectSum.of (fun M => quotientOrderPiece k I M) N q) = + DirectSum.of (fun M => quotientOrderPiece k I M) (N + 1) + (quotientOrderPieceSucc k I N q) := by + change (DirectSum.toModule k ℕ (QuotientOrderReesModule k I) fun N => + (DirectSum.lof k ℕ (fun M => quotientOrderPiece k I M) (N + 1)).comp + (quotientOrderPieceSucc k I N)) + (DirectSum.lof k ℕ (fun M => quotientOrderPiece k I M) N q) = _ + rw [DirectSum.toModule_lof, LinearMap.comp_apply, DirectSum.lof_eq_of] + +/-- The quotient map from one filtered piece to its associated graded piece. -/ +def quotientOrderPieceToGraded + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + quotientOrderPiece k I N →ₗ[k] QuotientOrderGradedPiece k I N := + ((quotientOrderStrictLowerPiece k I N).comap + (quotientOrderPiece k I N).subtype).mkQ + +/-- Global specialization of the filtered quotient direct sum to the actual +associated graded quotient. -/ +def quotientOrderReesToAssociatedGraded + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderReesModule k I →ₗ[k] QuotientOrderAssociatedGraded k I := + DirectSum.toModule k ℕ (QuotientOrderAssociatedGraded k I) fun N => + (DirectSum.lof k ℕ (fun M => QuotientOrderGradedPiece k I M) N).comp + (quotientOrderPieceToGraded k I N) + +@[simp] theorem quotientOrderReesToAssociatedGraded_of + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (q : quotientOrderPiece k I N) : + quotientOrderReesToAssociatedGraded k I + (DirectSum.of (fun M => quotientOrderPiece k I M) N q) = + DirectSum.of (fun M => QuotientOrderGradedPiece k I M) N + (quotientOrderPieceToGraded k I N q) := by + change (DirectSum.toModule k ℕ (QuotientOrderAssociatedGraded k I) fun N => + (DirectSum.lof k ℕ (fun M => QuotientOrderGradedPiece k I M) N).comp + (quotientOrderPieceToGraded k I N)) + (DirectSum.lof k ℕ (fun M => quotientOrderPiece k I M) N q) = _ + rw [DirectSum.toModule_lof, LinearMap.comp_apply, DirectSum.lof_eq_of] + +theorem quotientOrderPieceToGraded_succ_inclusion_eq_zero + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (q : quotientOrderPiece k I N) : + quotientOrderPieceToGraded k I (N + 1) + (quotientOrderPieceSucc k I N q) = 0 := by + change Submodule.Quotient.mk (quotientOrderPieceSucc k I N q) = 0 + rw [Submodule.Quotient.mk_eq_zero] + change (q : FilteredRightQuotient k I) ∈ + quotientOrderStrictLowerPiece k I (N + 1) + rw [quotientOrderStrictLowerPiece_succ_eq] + exact q.property + +/-- Specialization kills the successor shift. -/ +theorem quotientOrderReesToAssociatedGraded_comp_shift + (I : RightIdeal (PresentedWeyl k n)) : + (quotientOrderReesToAssociatedGraded k I).comp + (quotientOrderReesShift k I) = 0 := by + apply DirectSum.linearMap_ext + intro N + apply LinearMap.ext + intro q + change quotientOrderReesToAssociatedGraded k I + (quotientOrderReesShift k I + (DirectSum.of (fun M => quotientOrderPiece k I M) N q)) = 0 + rw [quotientOrderReesShift_of, quotientOrderReesToAssociatedGraded_of, + quotientOrderPieceToGraded_succ_inclusion_eq_zero] + exact map_zero _ + +/-- Every associated-graded class has a filtered Rees representative. -/ +theorem quotientOrderReesToAssociatedGraded_surjective + (I : RightIdeal (PresentedWeyl k n)) : + Function.Surjective (quotientOrderReesToAssociatedGraded k I) := by + intro g + induction g using DirectSum.induction_on with + | zero => + exact ⟨0, map_zero _⟩ + | of N q => + obtain ⟨p, rfl⟩ := Submodule.Quotient.mk_surjective + ((quotientOrderStrictLowerPiece k I N).comap + (quotientOrderPiece k I N).subtype) q + exact ⟨DirectSum.of (fun M => quotientOrderPiece k I M) N p, + quotientOrderReesToAssociatedGraded_of k I N p⟩ + | add x y hx hy => + obtain ⟨a, ha⟩ := hx + obtain ⟨b, hb⟩ := hy + refine ⟨a + b, ?_⟩ + calc + quotientOrderReesToAssociatedGraded k I (a + b) = + quotientOrderReesToAssociatedGraded k I a + + quotientOrderReesToAssociatedGraded k I b := map_add _ _ _ + _ = x + y := congrArg₂ (· + ·) ha hb + + +end + +end Stafford38.CharacteristicFilteredQuotientRees diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesAction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesAction.lean new file mode 100644 index 0000000000..c4ea4e5dc0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesAction.lean @@ -0,0 +1,542 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.OrderRees +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientRees +import Mathlib.Algebra.Module.GradedModule +import Mathlib.Algebra.Module.Equiv.Opposite + +/-! +# The right order-Rees action on the filtered quotient + +This file constructs the actual right action. Scalars are taken in the +opposite of the order-Rees ring, so homogeneous scalar action is written +right Weyl multiplication and raises filtration degree additively. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientReesAction + +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientRees +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylOrderRees + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-! ## The transparent right action on the additive quotient -/ + +/-- Right multiplication by a Weyl operator on the additive quotient. -/ +def filteredRightMul (I : RightIdeal (PresentedWeyl k n)) + (y : PresentedWeyl k n) : + FilteredRightQuotient k I →ₗ[k] FilteredRightQuotient k I := + (rightIdealKSubmodule k I).mapQ (rightIdealKSubmodule k I) + { toFun := fun z => z * y + map_add' := fun z w => add_mul z w y + map_smul' := fun c z => Algebra.smul_mul_assoc c z y } + (by + intro z hz + change z * y ∈ I + exact I.smul_mem (MulOpposite.op y) hz) + +@[simp] theorem filteredRightMul_mk + (I : RightIdeal (PresentedWeyl k n)) + (y z : PresentedWeyl k n) : + filteredRightMul k I y ((rightIdealKSubmodule k I).mkQ z) = + (rightIdealKSubmodule k I).mkQ (z * y) := + rfl + +@[simp] theorem filteredRightMul_one + (I : RightIdeal (PresentedWeyl k n)) + (q : FilteredRightQuotient k I) : + filteredRightMul k I 1 q = q := by + refine Submodule.Quotient.induction_on _ q ?_ + intro z + change (rightIdealKSubmodule k I).mkQ (z * 1) = + (rightIdealKSubmodule k I).mkQ z + rw [mul_one] + +/-- The right Weyl scalar action underlying the following module instance. -/ +def filteredRightQuotientOpSMul + (I : RightIdeal (PresentedWeyl k n)) : + SMul (PresentedWeyl k n)ᵐᵒᵖ (FilteredRightQuotient k I) := + ⟨fun y q => filteredRightMul k I y.unop q⟩ + +local instance filteredRightQuotientSMul + (I : RightIdeal (PresentedWeyl k n)) : + SMul (PresentedWeyl k n)ᵐᵒᵖ (FilteredRightQuotient k I) := + filteredRightQuotientOpSMul k I + +/-- The additive quotient is an honest right module over the Weyl algebra. -/ +def filteredRightQuotientOpModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (PresentedWeyl k n)ᵐᵒᵖ (FilteredRightQuotient k I) := + Module.ofMinimalAxioms + (fun y q₁ q₂ => by + refine Submodule.Quotient.induction_on _ q₁ ?_ + intro z + refine Submodule.Quotient.induction_on _ q₂ ?_ + intro w + change (rightIdealKSubmodule k I).mkQ ((z + w) * y.unop) = _ + rw [add_mul] + change (rightIdealKSubmodule k I).mkQ (z * y.unop + w * y.unop) = + (rightIdealKSubmodule k I).mkQ (z * y.unop) + + (rightIdealKSubmodule k I).mkQ (w * y.unop) + exact (rightIdealKSubmodule k I).mkQ.map_add _ _) + (fun y₁ y₂ q => by + refine Submodule.Quotient.induction_on _ q ?_ + intro z + change (rightIdealKSubmodule k I).mkQ (z * (y₁ + y₂).unop) = _ + rw [MulOpposite.unop_add, mul_add] + change (rightIdealKSubmodule k I).mkQ + (z * y₁.unop + z * y₂.unop) = + (rightIdealKSubmodule k I).mkQ (z * y₁.unop) + + (rightIdealKSubmodule k I).mkQ (z * y₂.unop) + exact (rightIdealKSubmodule k I).mkQ.map_add _ _) + (fun y₁ y₂ q => by + refine Submodule.Quotient.induction_on _ q ?_ + intro z + change (rightIdealKSubmodule k I).mkQ (z * (y₁ * y₂).unop) = _ + rw [MulOpposite.unop_mul] + change (rightIdealKSubmodule k I).mkQ (z * (y₂.unop * y₁.unop)) = + (rightIdealKSubmodule k I).mkQ ((z * y₂.unop) * y₁.unop) + rw [mul_assoc]) + (fun q => by + refine Submodule.Quotient.induction_on _ q ?_ + intro z + change (rightIdealKSubmodule k I).mkQ (z * (1 : PresentedWeyl k n)) = _ + rw [mul_one] + rfl) + +local instance filteredRightQuotientModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (PresentedWeyl k n)ᵐᵒᵖ (FilteredRightQuotient k I) := + filteredRightQuotientOpModule k I + +@[simp] theorem op_smul_filtered_mk + (I : RightIdeal (PresentedWeyl k n)) + (y z : PresentedWeyl k n) : + MulOpposite.op y • ((rightIdealKSubmodule k I).mkQ z) = + (rightIdealKSubmodule k I).mkQ (z * y) := + rfl + +/-! ## Opposite homogeneous pieces and their filtered action -/ + +/-- The degree-`N` order piece, placed in the opposite Weyl algebra. -/ +def orderPieceOp (N : ℕ) : Submodule k (PresentedWeyl k n)ᵐᵒᵖ := + (orderPiece k n N).map (MulOpposite.opLinearEquiv k).toLinearMap + +theorem mem_orderPieceOp_iff (N : ℕ) (y : (PresentedWeyl k n)ᵐᵒᵖ) : + y ∈ orderPieceOp (n := n) k N ↔ + y.unop ∈ orderPiece k n N := by + constructor + · rintro ⟨z, hz, rfl⟩ + simpa using hz + · intro hy + exact ⟨y.unop, hy, by simp⟩ + +local instance orderPieceOpGradedMonoid : + SetLike.GradedMonoid (orderPieceOp (n := n) k) where + one_mem := by + rw [mem_orderPieceOp_iff] + exact (orderPieceOne (n := n) k).property + mul_mem := by + intro N M y z hy hz + rw [mem_orderPieceOp_iff] at hy hz ⊢ + rw [MulOpposite.unop_mul] + simpa [Nat.add_comm] using mul_mem_orderPiece k hz hy + +local instance orderPieceOpGradedSMul + (I : RightIdeal (PresentedWeyl k n)) : + SetLike.GradedSMul (orderPieceOp (n := n) k) + (quotientOrderPiece k I) where + smul_mem := by + intro M N y q hy hq + obtain ⟨z, hz, rfl⟩ := hq + rw [mem_orderPieceOp_iff] at hy + refine ⟨z * y.unop, ?_, ?_⟩ + · simpa [Nat.add_comm] using mul_mem_orderPiece k hz hy + rfl + +/-! ## Coefficient decomposition of the Rees ring -/ + +/-- The external direct sum of opposite homogeneous order pieces. -/ +abbrev OppositeOrderPieceSum := + DirectSum ℕ (fun N => orderPieceOp (n := n) k N) + +/-- Insert the coefficients of an opposite Rees polynomial in the external +direct sum of opposite filtered pieces. -/ +def orderReesOpCoefficients + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) : + OppositeOrderPieceSum (n := n) k := + DirectSum.mk _ r.unop.val.support fun N => + ⟨MulOpposite.op (r.unop.val.coeff N), + (mem_orderPieceOp_iff k N _).2 (r.unop.property N)⟩ + +@[simp] theorem orderReesOpCoefficients_apply + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) (N : ℕ) : + ((orderReesOpCoefficients (n := n) k r) N : + (PresentedWeyl k n)ᵐᵒᵖ) = + MulOpposite.op (r.unop.val.coeff N) := by + by_cases hN : N ∈ r.unop.val.support + · rw [orderReesOpCoefficients, DirectSum.mk_apply_of_mem hN] + · rw [orderReesOpCoefficients, DirectSum.mk_apply_of_notMem hN] + rw [Polynomial.notMem_support_iff.mp hN] + rfl + +/-- Coefficient decomposition as an additive homomorphism. -/ +def orderReesOpToDirectSum : + (OrderReesRing (n := n) k)ᵐᵒᵖ →+ OppositeOrderPieceSum (n := n) k where + toFun := orderReesOpCoefficients (n := n) k + map_zero' := by + ext N + change ((orderReesOpCoefficients (n := n) k 0) N : + (PresentedWeyl k n)ᵐᵒᵖ) = 0 + rw [orderReesOpCoefficients_apply] + simp + map_add' r s := by + ext N + change ((orderReesOpCoefficients (n := n) k (r + s)) N : + (PresentedWeyl k n)ᵐᵒᵖ) = + ((orderReesOpCoefficients (n := n) k r) N : + (PresentedWeyl k n)ᵐᵒᵖ) + + ((orderReesOpCoefficients (n := n) k s) N : + (PresentedWeyl k n)ᵐᵒᵖ) + rw [orderReesOpCoefficients_apply, orderReesOpCoefficients_apply] + simp + +@[simp] theorem orderReesOpToDirectSum_apply + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) (N : ℕ) : + ((orderReesOpToDirectSum (n := n) k r) N : + (PresentedWeyl k n)ᵐᵒᵖ) = + MulOpposite.op (r.unop.val.coeff N) := by + exact orderReesOpCoefficients_apply k r N + +/-! ## The coefficient ring equivalence -/ + +/-- A homogeneous opposite filtered coefficient as an opposite Rees +monomial. -/ +def orderPieceOpToReesOp (N : ℕ) : + orderPieceOp (n := n) k N →+ + (OrderReesRing (n := n) k)ᵐᵒᵖ where + toFun y := + let hy : (y : (PresentedWeyl k n)ᵐᵒᵖ).unop ∈ orderPiece k n N := + (mem_orderPieceOp_iff (n := n) k N y).1 y.property + MulOpposite.op <| orderReesMonomial k N ⟨y.val.unop, hy⟩ + map_zero' := by + apply MulOpposite.unop_injective + apply Subtype.ext + simp [orderReesMonomial] + map_add' y z := by + apply MulOpposite.unop_injective + apply Subtype.ext + simp [orderReesMonomial] + +private theorem orderPieceOpToReesOp_one : + orderPieceOpToReesOp (n := n) k 0 + (@GradedMonoid.GOne.one ℕ + (fun N => orderPieceOp (n := n) k N) _ _) = 1 := by + apply MulOpposite.unop_injective + apply Subtype.ext + simp [orderPieceOpToReesOp, orderReesMonomial] + +private theorem orderPieceOpToReesOp_mul + {N M : ℕ} (y : orderPieceOp (n := n) k N) + (z : orderPieceOp (n := n) k M) : + orderPieceOpToReesOp (n := n) k (N + M) + (@GradedMonoid.GMul.mul ℕ + (fun L => orderPieceOp (n := n) k L) _ _ N M y z) = + orderPieceOpToReesOp (n := n) k N y * + orderPieceOpToReesOp (n := n) k M z := by + apply MulOpposite.unop_injective + apply Subtype.ext + simp only [orderPieceOpToReesOp, MulOpposite.unop_op, + MulOpposite.unop_mul] + simp [orderReesMonomial, Polynomial.monomial_mul_monomial, + Nat.add_comm] + +/-- Recompose opposite homogeneous coefficients into an opposite Rees +polynomial. -/ +def orderPieceOpDirectSumToReesOp : + OppositeOrderPieceSum (n := n) k →+* + (OrderReesRing (n := n) k)ᵐᵒᵖ := + DirectSum.toSemiring (fun N => orderPieceOpToReesOp (n := n) k N) + (orderPieceOpToReesOp_one (n := n) k) + (orderPieceOpToReesOp_mul (n := n) k) + +@[simp] theorem orderPieceOpDirectSumToReesOp_of + (N : ℕ) (y : orderPieceOp (n := n) k N) : + orderPieceOpDirectSumToReesOp (n := n) k + (DirectSum.of (fun M => orderPieceOp (n := n) k M) N y) = + orderPieceOpToReesOp (n := n) k N y := by + exact DirectSum.toSemiring_of _ _ _ _ _ + +theorem orderPieceOpDirectSumToReesOp_coeff + (x : OppositeOrderPieceSum (n := n) k) (N : ℕ) : + ((orderPieceOpDirectSumToReesOp (n := n) k x).unop.val.coeff N) = + ((x N : orderPieceOp (n := n) k N) : + (PresentedWeyl k n)ᵐᵒᵖ).unop := by + induction x using DirectSum.induction_on with + | zero => simp + | of M y => + rw [orderPieceOpDirectSumToReesOp_of] + by_cases hMN : M = N + · subst N + simp [orderPieceOpToReesOp, orderReesMonomial] + · simp [orderPieceOpToReesOp, orderReesMonomial, + Polynomial.coeff_monomial, DirectSum.of_apply, hMN] + | add x y hx hy => + rw [map_add] + change (((orderPieceOpDirectSumToReesOp (n := n) k x).unop.val + + (orderPieceOpDirectSumToReesOp (n := n) k y).unop.val).coeff N) = _ + rw [Polynomial.coeff_add, hx, hy] + rfl + +theorem orderPieceOpDirectSumToReesOp_leftInverse : + Function.LeftInverse (orderReesOpToDirectSum (n := n) k) + (orderPieceOpDirectSumToReesOp (n := n) k) := by + intro x + ext N + change (((orderReesOpToDirectSum (n := n) k) + (orderPieceOpDirectSumToReesOp (n := n) k x)) N : + (PresentedWeyl k n)ᵐᵒᵖ) = + (x N : (PresentedWeyl k n)ᵐᵒᵖ) + rw [orderReesOpToDirectSum_apply] + rw [orderPieceOpDirectSumToReesOp_coeff] + exact MulOpposite.op_unop _ + +theorem orderPieceOpDirectSumToReesOp_rightInverse : + Function.RightInverse (orderReesOpToDirectSum (n := n) k) + (orderPieceOpDirectSumToReesOp (n := n) k) := by + intro r + apply MulOpposite.unop_injective + apply Subtype.ext + apply Polynomial.ext + intro N + rw [orderPieceOpDirectSumToReesOp_coeff] + rw [orderReesOpToDirectSum_apply] + exact MulOpposite.unop_op _ + +/-- The coefficient decomposition is an equivalence of rings, with the +opposite multiplication recording written right Weyl multiplication. -/ +def orderPieceOpDirectSumEquivReesOp : + OppositeOrderPieceSum (n := n) k ≃+* + (OrderReesRing (n := n) k)ᵐᵒᵖ := + RingEquiv.ofBijective (orderPieceOpDirectSumToReesOp (n := n) k) + ⟨(orderPieceOpDirectSumToReesOp_leftInverse (n := n) k).injective, + (orderPieceOpDirectSumToReesOp_rightInverse (n := n) k).surjective⟩ + +@[simp] theorem orderPieceOpDirectSumEquivReesOp_symm_apply + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) : + (orderPieceOpDirectSumEquivReesOp (n := n) k).symm r = + orderReesOpToDirectSum (n := n) k r := by + apply (orderPieceOpDirectSumEquivReesOp (n := n) k).injective + rw [RingEquiv.apply_symm_apply] + exact (orderPieceOpDirectSumToReesOp_rightInverse (n := n) k r).symm + +/-! ## The right Rees action -/ + +/-! +Lean 4.33 matches instance arguments only up to instance transparency. The +`VAdd ℕ ℕ` that elaboration picks here is the one derived from `Add`, while +`SetLike.gmulAction` and its successors state their conclusions with the one +derived from `AddAction`, so Mathlib's internal graded-module instances no +longer apply to the pieces above. The three instances below are Mathlib's +own constructions written in this file's shape; each proof obligation is +discharged exactly as upstream. +-/ + +local instance orderPieceOpGMulAction + (I : RightIdeal (PresentedWeyl k n)) : + GradedMonoid.GMulAction (fun N => orderPieceOp (n := n) k N) + (fun N => quotientOrderPiece k I N) := + { SetLike.toGSMul (orderPieceOp (n := n) k) (quotientOrderPiece k I) with + one_smul := fun ⟨_i, _m⟩ => + Sigma.subtype_ext (zero_vadd _ _) (one_smul _ _) + mul_smul := fun ⟨_i, _a⟩ ⟨_j, _a'⟩ ⟨_l, _b⟩ => + Sigma.subtype_ext (add_vadd _ _ _) (mul_smul _ _ _) } + +local instance orderPieceOpGdistribMulAction + (I : RightIdeal (PresentedWeyl k n)) : + DirectSum.GdistribMulAction (fun N => orderPieceOp (n := n) k N) + (fun N => quotientOrderPiece k I N) := + { orderPieceOpGMulAction (n := n) k I with + smul_add := fun _a _b _c => Subtype.ext <| smul_add _ _ _ + smul_zero := fun _a => Subtype.ext <| smul_zero _ } + +local instance orderPieceOpGmodule + (I : RightIdeal (PresentedWeyl k n)) : + DirectSum.Gmodule (fun N => orderPieceOp (n := n) k N) + (fun N => quotientOrderPiece k I N) := + { orderPieceOpGdistribMulAction (n := n) k I with + add_smul := fun _a _a' _b => Subtype.ext <| add_smul _ _ _ + zero_smul := fun _b => Subtype.ext <| zero_smul _ _ } + +/-- The honest right order-Rees module structure. Its scalar ring is +opposite because `op r • q` means `q * r` in written Weyl order. -/ +noncomputable instance quotientOrderReesModuleOrderReesOpModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (OrderReesRing (n := n) k)ᵐᵒᵖ + (QuotientOrderReesModule k I) := + Module.compHom (QuotientOrderReesModule k I) + (orderPieceOpDirectSumEquivReesOp (n := n) k).symm.toRingHom + +theorem op_smul_mem_quotientOrderPiece + (I : RightIdeal (PresentedWeyl k n)) + {N M : ℕ} (q : quotientOrderPiece k I N) + (y : orderPiece k n M) : + filteredRightMul k I y (q : FilteredRightQuotient k I) ∈ + quotientOrderPiece k I (M + N) := by + obtain ⟨z, hz, hq⟩ := q.property + refine ⟨z * (y : PresentedWeyl k n), + ?_, ?_⟩ + · simpa [Nat.add_comm] using mul_mem_orderPiece k hz y.property + rw [← hq] + rfl + +theorem cast_quotientOrderPiece_coe + (I : RightIdeal (PresentedWeyl k n)) + {A B : ℕ} (h : A = B) (q : quotientOrderPiece k I A) : + ((h ▸ q : quotientOrderPiece k I B) : FilteredRightQuotient k I) = q := by + subst B + rfl + +/-- Homogeneous Rees action is represented by written right Weyl +multiplication and has the sum of the declared degrees. -/ +theorem orderReesMonomial_op_smul_of + (I : RightIdeal (PresentedWeyl k n)) + {N M : ℕ} (q : quotientOrderPiece k I N) + (y : orderPiece k n M) : + MulOpposite.op (orderReesMonomial k M y) • + DirectSum.of (fun L => quotientOrderPiece k I L) N q = + DirectSum.of (fun L => quotientOrderPiece k I L) (M + N) + ⟨filteredRightMul k I y (q : FilteredRightQuotient k I), + op_smul_mem_quotientOrderPiece k I q y⟩ := by + change + (orderPieceOpDirectSumEquivReesOp (n := n) k).symm + (MulOpposite.op (orderReesMonomial k M y)) • + DirectSum.of (fun L => quotientOrderPiece k I L) N q = _ + rw [orderPieceOpDirectSumEquivReesOp_symm_apply] + have hcoeff : + orderReesOpToDirectSum (n := n) k + (MulOpposite.op (orderReesMonomial k M y)) = + DirectSum.of (fun L => orderPieceOp (n := n) k L) M + ⟨MulOpposite.op (y : PresentedWeyl k n), + (mem_orderPieceOp_iff k M _).2 y.property⟩ := by + ext L + by_cases hLM : M = L + · subst L + rw [DirectSum.of_eq_same] + rw [orderReesOpToDirectSum_apply] + simp [orderReesMonomial] + · rw [DirectSum.of_eq_of_ne M L _ (Ne.symm hLM)] + rw [orderReesOpToDirectSum_apply] + simp [orderReesMonomial, Polynomial.coeff_monomial, hLM] + rw [hcoeff, DirectSum.Gmodule.of_smul_of] + congr 1 + +/-- The opposite Rees parameter decomposes as the degree-one unit +coefficient. -/ +theorem orderReesParameter_op_decomposition : + (orderPieceOpDirectSumEquivReesOp (n := n) k).symm + (MulOpposite.op (orderReesParameter (n := n) k)) = + DirectSum.of (fun L => orderPieceOp (n := n) k L) 1 + ⟨MulOpposite.op (1 : PresentedWeyl k n), + (mem_orderPieceOp_iff k 1 _).2 + (presentedWeightPiece_mono k orderWeight (Nat.zero_le 1) + (orderPieceOne (n := n) k).property)⟩ := by + rw [orderPieceOpDirectSumEquivReesOp_symm_apply] + ext L + by_cases hL : L = 1 + · subst L + rw [DirectSum.of_eq_same] + rw [orderReesOpToDirectSum_apply] + simp [orderReesParameter_coe] + · rw [DirectSum.of_eq_of_ne 1 L _ hL] + rw [orderReesOpToDirectSum_apply] + simp [orderReesParameter_coe, Polynomial.coeff_X, hL, Ne.symm hL] + +/-- The central Rees parameter acts exactly as the previously constructed +successor shift. -/ +theorem orderReesParameter_op_smul_eq_shift + (I : RightIdeal (PresentedWeyl k n)) + (q : QuotientOrderReesModule k I) : + MulOpposite.op (orderReesParameter (n := n) k) • q = + quotientOrderReesShift k I q := by + induction q using DirectSum.induction_on with + | zero => simp + | of N q => + change MulOpposite.op + (orderReesMonomial k 1 + ⟨1, presentedWeightPiece_mono k orderWeight (Nat.zero_le 1) + (orderPieceOne (n := n) k).property⟩) • + DirectSum.of (fun L => quotientOrderPiece k I L) N q = _ + rw [orderReesMonomial_op_smul_of k I q + ⟨1, presentedWeightPiece_mono k orderWeight (Nat.zero_le 1) + (orderPieceOne (n := n) k).property⟩] + let q' : quotientOrderPiece k I (1 + N) := + ⟨q, by + simpa [Nat.one_add] using + quotientOrderPiece_mono k I (Nat.le_succ N) q.property⟩ + have hq' : + (⟨filteredRightMul k I 1 + (q : FilteredRightQuotient k I), + op_smul_mem_quotientOrderPiece k I q + ⟨1, presentedWeightPiece_mono k orderWeight (Nat.zero_le 1) + (orderPieceOne (n := n) k).property⟩⟩ : + quotientOrderPiece k I (1 + N)) = q' := by + apply Subtype.ext + exact filteredRightMul_one k I q + rw [hq'] + rw [quotientOrderReesShift_of] + ext L + by_cases hL : N + 1 = L + · subst L + simp [DirectSum.of_apply, Nat.one_add] + apply Subtype.ext + simp only [quotientOrderPieceSucc, Submodule.coe_inclusion] + exact (cast_quotientOrderPiece_coe k I (Nat.one_add N) q').trans rfl + · simp [DirectSum.of_apply, Nat.one_add, hL] + | add q r hq hr => + rw [smul_add, map_add, hq, hr] + +/-- Functional exact-signature form of parameter action. -/ +theorem orderReesParameter_op_smul_fun_eq_shift + (I : RightIdeal (PresentedWeyl k n)) : + (fun q : QuotientOrderReesModule k I => + MulOpposite.op (orderReesParameter (n := n) k) • q) = + quotientOrderReesShift k I := by + funext q + exact orderReesParameter_op_smul_eq_shift k I q + +/-- Centrality of the Rees parameter is reflected by commuting scalar +operators on the right Rees module. -/ +theorem orderReesParameter_op_smul_comm + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) + (q : QuotientOrderReesModule k I) : + MulOpposite.op (orderReesParameter (n := n) k) • + (MulOpposite.op r • q) = + MulOpposite.op r • + (MulOpposite.op (orderReesParameter (n := n) k) • q) := by + rw [← mul_smul, ← mul_smul] + congr 1 + apply MulOpposite.unop_injective + simp only [MulOpposite.unop_mul, MulOpposite.unop_op] + exact (orderReesParameter_mul_comm k r).symm + + +end + +end Stafford38.CharacteristicFilteredQuotientReesAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesExact.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesExact.lean new file mode 100644 index 0000000000..9f5346c5c1 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientReesExact.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientRees + +/-! +# Exact specialization of the filtered quotient Rees direct sum + +This file completes the additive exactness statement for the concrete direct +sum constructed in `FilteredQuotientRees`. The filtration inclusions make the +degree shift injective, and the kernel of the componentwise associated-graded +quotient is exactly its range. + +Only `k`-linear maps are used here. In particular, this file introduces no +Rees-ring action and asserts no special-fibre ring or module equivalence. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientReesExact + +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicFilteredQuotientRees +open Stafford38.EulerSurjectivity +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private theorem quotientOrderReesShift_apply_succ + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) (N : ℕ) : + (quotientOrderReesShift k I x) (N + 1) = + quotientOrderPieceSucc k I N (x N) := by + induction x using DirectSum.induction_on with + | zero => simp + | of M q => + rw [quotientOrderReesShift_of] + simp only [DirectSum.of_apply] + by_cases h : M = N + · subst M + simp + · have hs : M + 1 ≠ N + 1 := by omega + simp [h, hs] + | add x y hx hy => + simpa using congrArg₂ (· + ·) hx hy + +private theorem quotientOrderReesToAssociatedGraded_apply + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) (N : ℕ) : + (quotientOrderReesToAssociatedGraded k I x) N = + quotientOrderPieceToGraded k I N (x N) := by + induction x using DirectSum.induction_on with + | zero => simp + | of M q => + rw [quotientOrderReesToAssociatedGraded_of] + simp only [DirectSum.of_apply] + by_cases h : M = N + · subst M + simp + · simp [h] + | add x y hx hy => + simpa using congrArg₂ (· + ·) hx hy + +/-- The degree-raising filtration shift on the concrete quotient Rees direct +sum is injective. -/ +theorem quotientOrderReesShift_injective + (I : RightIdeal (PresentedWeyl k n)) : + Function.Injective (quotientOrderReesShift k I) := by + intro x y hxy + apply DFinsupp.ext + intro N + have hcomponent := congrArg (fun z => z (N + 1)) hxy + change (quotientOrderReesShift k I x) (N + 1) = + (quotientOrderReesShift k I y) (N + 1) at hcomponent + rw [quotientOrderReesShift_apply_succ, + quotientOrderReesShift_apply_succ] at hcomponent + have hval : + ((quotientOrderPieceSucc k I N (x N) : + quotientOrderPiece k I (N + 1)) : FilteredRightQuotient k I) = + ((quotientOrderPieceSucc k I N (y N) : + quotientOrderPiece k I (N + 1)) : FilteredRightQuotient k I) := + congrArg + (fun z : quotientOrderPiece k I (N + 1) => + (z : FilteredRightQuotient k I)) hcomponent + apply Subtype.ext + exact hval + +private theorem homogeneous_mem_range_of_specialization_eq_zero + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (q : quotientOrderPiece k I N) + (hq : quotientOrderPieceToGraded k I N q = 0) : + DirectSum.of (fun M => quotientOrderPiece k I M) N q ∈ + LinearMap.range (quotientOrderReesShift k I) := by + cases N with + | zero => + have hmem := (Submodule.Quotient.mk_eq_zero _).mp hq + have hqzero : q = 0 := by + apply Subtype.ext + change (q : FilteredRightQuotient k I) = 0 + simpa [quotientOrderStrictLowerPiece, + Stafford38.WeylAssociatedGraded.presentedStrictLowerPiece] using hmem + subst q + rw [map_zero] + exact (LinearMap.range (quotientOrderReesShift k I)).zero_mem + | succ N => + have hmem := (Submodule.Quotient.mk_eq_zero _).mp hq + have hprev : (q : FilteredRightQuotient k I) ∈ + quotientOrderPiece k I N := by + simpa [quotientOrderStrictLowerPiece_succ_eq] using hmem + let qprev : quotientOrderPiece k I N := ⟨q, hprev⟩ + refine ⟨DirectSum.of (fun M => quotientOrderPiece k I M) N qprev, ?_⟩ + rw [quotientOrderReesShift_of] + congr 1 + +/-- Exactness of specialization for the concrete filtered quotient direct sum: +the elements killed by passage to the associated graded object are precisely +the images of the degree-raising filtration shift. -/ +theorem quotientOrderReesToAssociatedGraded_ker_eq_range_shift + (I : RightIdeal (PresentedWeyl k n)) : + LinearMap.ker (quotientOrderReesToAssociatedGraded k I) = + LinearMap.range (quotientOrderReesShift k I) := by + classical + apply le_antisymm + · intro x hx + have hmap : quotientOrderReesToAssociatedGraded k I x = 0 := + LinearMap.mem_ker.mp hx + rw [← DirectSum.sum_support_of x] + apply Submodule.sum_mem + intro N hN + apply homogeneous_mem_range_of_specialization_eq_zero k I N + have hcomponent := congrArg (fun z => z N) hmap + simpa [quotientOrderReesToAssociatedGraded_apply] using hcomponent + · intro x hx + obtain ⟨y, rfl⟩ := hx + apply LinearMap.mem_ker.mpr + have hcomp := LinearMap.congr_fun + (quotientOrderReesToAssociatedGraded_comp_shift k I) y + simpa using hcomp + + +end + +end Stafford38.CharacteristicFilteredQuotientReesExact diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSpecialFibre.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSpecialFibre.lean new file mode 100644 index 0000000000..ca46cd2380 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSpecialFibre.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesExact + +/-! +# Additive special fibre of the filtered quotient direct sum + +The exact successor-shift sequence identifies the quotient by the shift range +with the actual associated graded module. This is a `k`-linear equivalence +only. The right order-Rees action and its parameter compatibility are separate. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientSpecialFibre + +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicFilteredQuotientRees +open Stafford38.CharacteristicFilteredQuotientReesExact +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The additive quotient by the successor-shift range is the actual +associated graded quotient. -/ +def quotientOrderShiftQuotientLinearEquiv + (I : RightIdeal (PresentedWeyl k n)) : + (QuotientOrderReesModule k I ⧸ + LinearMap.range (quotientOrderReesShift k I)) ≃ₗ[k] + QuotientOrderAssociatedGraded k I := + (Submodule.quotEquivOfEq + (LinearMap.range (quotientOrderReesShift k I)) + (LinearMap.ker (quotientOrderReesToAssociatedGraded k I)) + (quotientOrderReesToAssociatedGraded_ker_eq_range_shift k I).symm).trans + ((quotientOrderReesToAssociatedGraded k I).quotKerEquivOfSurjective + (quotientOrderReesToAssociatedGraded_surjective k I)) + +@[simp] theorem quotientOrderShiftQuotientLinearEquiv_mk + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) : + quotientOrderShiftQuotientLinearEquiv k I + (Submodule.Quotient.mk x) = + quotientOrderReesToAssociatedGraded k I x := by + rfl + + +end + +end Stafford38.CharacteristicFilteredQuotientSpecialFibre diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSupport.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSupport.lean new file mode 100644 index 0000000000..cf847eeeb1 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientSupport.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous + +/-! +# Global support of the filtered right-ideal quotient + +The exact homogeneous relation theorem identifies, as an additive group and +as a vector space over the coefficient field, the external direct sum of the +actual filtered quotient pieces with the quotient of the symbol ring by the +order initial ideal. + +The further transport of the full symbol-ring module structure, and hence the +support equality, is not proved in this file. No conclusion about vanishing +of the ungraded Weyl quotient is made here. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientSupport + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (n := n) k) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- Decompose a symbol into homogeneous pieces and reduce each piece by the +exact relation submodule of the filtered quotient. -/ +def symbolToOrderRelationGraded + (I : RightIdeal (PresentedWeyl k n)) : + SymbolRing k n →ₗ[k] OrderSymbolRelationGraded k I := + (DFinsupp.mapRange.linearMap fun N => + (orderSymbolRelation k I N).mkQ).comp + (DirectSum.decomposeLinearEquiv (orderDecomposition (n := n) k)).toLinearMap + +@[simp] theorem symbolToOrderRelationGraded_apply + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) (N : ℕ) : + symbolToOrderRelationGraded k I P N = + Submodule.Quotient.mk + (DirectSum.decompose (orderDecomposition (n := n) k) P N) := by + rfl + +/-- The global symbol map is onto: choose a representative in each nonzero +homogeneous quotient component and reassemble the resulting finite family. -/ +theorem symbolToOrderRelationGraded_surjective + (I : RightIdeal (PresentedWeyl k n)) : + Function.Surjective (symbolToOrderRelationGraded k I) := by + classical + intro q + let lift : ∀ N, + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N ⧸ + orderSymbolRelation k I N) → + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N := + fun N qN => if hq : qN = 0 then 0 else Classical.choose + (Submodule.Quotient.mk_surjective (orderSymbolRelation k I N) qN) + have hlift : ∀ N qN, Submodule.Quotient.mk (lift N qN) = qN := by + intro N qN + by_cases hq : qN = 0 + · simp [lift, hq] + · simpa [lift, hq] using Classical.choose_spec + (Submodule.Quotient.mk_surjective (orderSymbolRelation k I N) qN) + let q' : DirectSum ℕ (fun N => + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N) := + DFinsupp.mapRange lift (fun N => by simp [lift]) q + refine ⟨(DirectSum.decomposeLinearEquiv + (orderDecomposition (n := n) k)).symm q', ?_⟩ + apply DFinsupp.ext + intro N + rw [symbolToOrderRelationGraded_apply] + have hd := (DirectSum.decomposeAddEquiv + (orderDecomposition (n := n) k)).apply_symm_apply q' + rw [show DirectSum.decompose (orderDecomposition (n := n) k) + ((DirectSum.decomposeLinearEquiv + (orderDecomposition (n := n) k)).symm q') N = q' N from + congrArg (fun z => z N) hd] + change Submodule.Quotient.mk (q' N) = q N + exact hlift N (q N) + +/-- The kernel of the global symbol map is exactly the order initial ideal, +viewed as a `k`-submodule. -/ +theorem ker_symbolToOrderRelationGraded + (I : RightIdeal (PresentedWeyl k n)) : + LinearMap.ker (symbolToOrderRelationGraded k I) = + (orderInitialIdeal k I).restrictScalars k := by + ext P + constructor + · intro hP + rw [LinearMap.mem_ker] at hP + have hcomponent : ∀ N, + DirectSum.decompose (orderDecomposition (n := n) k) P N ∈ + orderSymbolRelation k I N := by + intro N + rw [← Submodule.Quotient.mk_eq_zero] + exact congrArg (fun q => q N) hP + change P ∈ orderInitialIdeal k I + classical + rw [← DirectSum.sum_support_decompose (orderDecomposition (n := n) k) P] + apply Ideal.sum_mem + intro N hN + exact (mem_orderSymbolRelation_iff_coe_mem_orderInitialIdeal k I N _).mp + (hcomponent N) + · intro hP + rw [LinearMap.mem_ker] + apply DFinsupp.ext + intro N + change Submodule.Quotient.mk + (DirectSum.decompose (orderDecomposition (n := n) k) P N) = 0 + rw [Submodule.Quotient.mk_eq_zero] + exact decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k I P hP N + +/-- The cyclic order-characteristic module is linearly equivalent over the +coefficient field to the direct sum of the exact homogeneous quotients. -/ +def orderCharacteristicModuleEquivRelationGraded + (I : RightIdeal (PresentedWeyl k n)) : + (SymbolRing k n ⧸ (orderInitialIdeal k I).restrictScalars k) ≃ₗ[k] + OrderSymbolRelationGraded k I := + Submodule.quotEquivOfEq _ _ (ker_symbolToOrderRelationGraded k I).symm ≪≫ₗ + (symbolToOrderRelationGraded k I).quotKerEquivOfSurjective + (symbolToOrderRelationGraded_surjective k I) + +/-- The actual associated graded object is globally equivalent, as a +`k`-vector space, to the cyclic symbol quotient. Its restriction to each +degree is the previously proved filtered-quotient equivalence. -/ +def quotientOrderAssociatedGradedEquivCharacteristic + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderAssociatedGraded k I ≃ₗ[k] + (SymbolRing k n ⧸ (orderInitialIdeal k I).restrictScalars k) := + quotientOrderAssociatedGradedEquivSymbols k I ≪≫ₗ + (orderCharacteristicModuleEquivRelationGraded k I).symm + +/-- Restricting the scalar ring of an ideal does not change the underlying +additive quotient. -/ +def restrictScalarsQuotientAddEquiv + (I : RightIdeal (PresentedWeyl k n)) : + (SymbolRing k n ⧸ (orderInitialIdeal k I).restrictScalars k) ≃+ + OrderCharacteristicModule k I where + toEquiv := Quotient.congr (Equiv.refl _) (by + intro P Q + rfl) + map_add' q r := by + refine Quotient.inductionOn₂ q r ?_ + intro P Q + rfl + +/-- Additive global equivalence from the actual associated graded pieces to +the cyclic symbol quotient. -/ +def quotientOrderAssociatedGradedAddEquivCharacteristic + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderAssociatedGraded k I ≃+ OrderCharacteristicModule k I := + (quotientOrderAssociatedGradedEquivCharacteristic k I).toAddEquiv.trans + (restrictScalarsQuotientAddEquiv k I) + + +end + +end Stafford38.CharacteristicFilteredQuotientSupport diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientTwoJet.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientTwoJet.lean new file mode 100644 index 0000000000..5401dc745d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredQuotientTwoJet.lean @@ -0,0 +1,732 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesAction +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientReesExact +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientSpecialFibre +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJet + +/-! +# The filtered quotient two-jet module + +This file constructs the concrete right module over the order-Rees two-jet. +The underlying additive quotient is the filtered Rees direct sum modulo the +image of the square of the successor shift. The scalar ring is opposite, so +its action retains written right Weyl multiplication. + +No trace theorem, minimal-prime statement, or Gabber theorem is asserted. +-/ + +namespace Stafford38.CharacteristicFilteredQuotientTwoJet + +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotientRees +open Stafford38.CharacteristicFilteredQuotientReesAction +open Stafford38.CharacteristicFilteredQuotientReesExact +open Stafford38.CharacteristicFilteredQuotientSpecialFibre +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylOrderRees + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +local instance quotientOrderAssociatedGradedSymbolModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (Stafford38.Characteristic.SymbolRing k n) + (Stafford38.CharacteristicFilteredQuotientGraded.QuotientOrderAssociatedGraded k I) := + inferInstanceAs (Module (Stafford38.Characteristic.SymbolRing k n) + (OrderAssociatedGradedModule k I)) + +local instance filteredRightQuotientSMul + (I : RightIdeal (PresentedWeyl k n)) : + SMul (PresentedWeyl k n)ᵐᵒᵖ + (Stafford38.CharacteristicFilteredQuotient.FilteredRightQuotient k I) := + filteredRightQuotientOpSMul k I + +local instance filteredRightQuotientModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (PresentedWeyl k n)ᵐᵒᵖ + (Stafford38.CharacteristicFilteredQuotient.FilteredRightQuotient k I) := + filteredRightQuotientOpModule k I + +local instance orderPieceOpGradedMonoid : + SetLike.GradedMonoid + (CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k) where + one_mem := by + rw [mem_orderPieceOp_iff] + exact (Stafford38.CharacteristicAssociatedGradedModule.orderPieceOne + (n := n) k).property + mul_mem := by + intro N M y z hy hz + rw [mem_orderPieceOp_iff] at hy hz ⊢ + rw [MulOpposite.unop_mul] + simpa [Nat.add_comm] using + Stafford38.WeylFiltration.mul_mem_orderPiece k hz hy + +local instance orderPieceOpGradedSMul + (I : RightIdeal (PresentedWeyl k n)) : + SetLike.GradedSMul + (CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k) + (Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I) where + smul_mem := by + intro M N y q hy hq + obtain ⟨z, hz, rfl⟩ := hq + rw [mem_orderPieceOp_iff] at hy + refine ⟨z * y.unop, ?_, ?_⟩ + · simpa [Nat.add_comm] using + Stafford38.WeylFiltration.mul_mem_orderPiece k hz hy + rfl + +/-! +Lean 4.33 matches instance arguments only up to instance transparency, so +Mathlib's internal graded-module chain no longer derives from the +`SetLike.GradedSMul` above: the `VAdd ℕ ℕ` it picks is the one derived from +`Add`, not from `AddAction`. These are Mathlib's own constructions written in +this file's shape, exactly as already done in `FilteredQuotientReesAction`. +-/ + +local instance orderPieceOpGMulAction + (I : RightIdeal (PresentedWeyl k n)) : + GradedMonoid.GMulAction + (fun N => CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k N) + (fun N => Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I N) := + { SetLike.toGSMul + (CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k) + (Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I) with + one_smul := fun ⟨_i, _m⟩ => + Sigma.subtype_ext (zero_vadd _ _) (one_smul _ _) + mul_smul := fun ⟨_i, _a⟩ ⟨_j, _a'⟩ ⟨_l, _b⟩ => + Sigma.subtype_ext (add_vadd _ _ _) (mul_smul _ _ _) } + +local instance orderPieceOpGdistribMulAction + (I : RightIdeal (PresentedWeyl k n)) : + DirectSum.GdistribMulAction + (fun N => CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k N) + (fun N => Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I N) := + { orderPieceOpGMulAction (n := n) k I with + smul_add := fun _a _b _c => Subtype.ext <| smul_add _ _ _ + smul_zero := fun _a => Subtype.ext <| smul_zero _ } + +local instance orderPieceOpGmodule + (I : RightIdeal (PresentedWeyl k n)) : + DirectSum.Gmodule + (fun N => CharacteristicFilteredQuotientReesAction.orderPieceOp (n := n) k N) + (fun N => Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I N) := + { orderPieceOpGdistribMulAction (n := n) k I with + add_smul := fun _a _a' _b => Subtype.ext <| add_smul _ _ _ + zero_smul := fun _b => Subtype.ext <| zero_smul _ _ } + +/-- The image of the square of the Rees-parameter shift. -/ +def quotientOrderReesTwoJetSubmodule + (I : RightIdeal (PresentedWeyl k n)) : + Submodule k (QuotientOrderReesModule k I) := + LinearMap.range + ((quotientOrderReesShift k I).comp (quotientOrderReesShift k I)) + +/-- The filtered quotient direct sum modulo the action of `T²`. -/ +abbrev FilteredQuotientTwoJet + (I : RightIdeal (PresentedWeyl k n)) := + QuotientOrderReesModule k I ⧸ quotientOrderReesTwoJetSubmodule k I + +/-- `Module.ofMinimalAxioms` below states its conclusion over the additive +monoid derived from `AddCommGroup`, while the quotient's own additive monoid +is `Submodule.Quotient.addCommMonoid`. Under Lean 4.33's instance +transparency those are no longer interchangeable, so `add_smul`, `neg_smul` +and `mul_smul` would not apply to the source action. Aligning the monoid here +is the same repair made for the filtered quotient itself. -/ +instance (priority := 10000) filteredQuotientTwoJetAddCommMonoid + (I : RightIdeal (PresentedWeyl k n)) : + AddCommMonoid (FilteredQuotientTwoJet k I) := + AddCommGroup.toAddCommMonoid + +/-- The canonical quotient map onto the module two-jet. -/ +def filteredQuotientTwoJetQuotient + (I : RightIdeal (PresentedWeyl k n)) : + QuotientOrderReesModule k I →ₗ[k] FilteredQuotientTwoJet k I := + (quotientOrderReesTwoJetSubmodule k I).mkQ + +@[simp] theorem filteredQuotientTwoJetQuotient_apply + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) : + filteredQuotientTwoJetQuotient k I x = Submodule.Quotient.mk x := + rfl + +private theorem oppositeOrderPieceSum_smul_comm + (I : RightIdeal (PresentedWeyl k n)) + (r : OppositeOrderPieceSum (n := n) k) (a : k) + (x : QuotientOrderReesModule k I) : + r • (a • x) = a • (r • x) := by + induction r using DirectSum.induction_on with + | zero => simp + | of M y => + induction x using DirectSum.induction_on with + | zero => simp + | of N q => + rw [← DirectSum.of_smul] + rw [DirectSum.Gmodule.of_smul_of, + DirectSum.Gmodule.of_smul_of] + rw [← DirectSum.of_smul] + congr 1 + apply Subtype.ext + exact (filteredRightMul k I y.val.unop).map_smul a q + | add x z hx hz => + simpa [smul_add] using congrArg₂ (fun p q => p + q) hx hz + | add r s hr hs => + simpa [add_smul] using congrArg₂ (fun p q => p + q) hr hs + +local instance quotientOrderReesModule_smulCommClass + (I : RightIdeal (PresentedWeyl k n)) : + SMulCommClass (OrderReesRing (n := n) k)ᵐᵒᵖ k + (QuotientOrderReesModule k I) where + smul_comm r a x := by + change + (orderPieceOpDirectSumEquivReesOp (n := n) k).symm r • (a • x) = + a • ((orderPieceOpDirectSumEquivReesOp (n := n) k).symm r • x) + exact oppositeOrderPieceSum_smul_comm k I _ _ _ + +theorem op_smul_mem_quotientOrderReesTwoJetSubmodule + (I : RightIdeal (PresentedWeyl k n)) + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) + {x : QuotientOrderReesModule k I} + (hx : x ∈ quotientOrderReesTwoJetSubmodule k I) : + r • x ∈ quotientOrderReesTwoJetSubmodule k I := by + obtain ⟨y, rfl⟩ := hx + refine ⟨r • y, ?_⟩ + change quotientOrderReesShift k I (quotientOrderReesShift k I (r • y)) = + r • quotientOrderReesShift k I (quotientOrderReesShift k I y) + calc + quotientOrderReesShift k I (quotientOrderReesShift k I (r • y)) = + quotientOrderReesShift k I + (r • quotientOrderReesShift k I y) := by + congr 1 + simpa only [MulOpposite.op_unop, + orderReesParameter_op_smul_eq_shift] using + (orderReesParameter_op_smul_comm k I r.unop y) + _ = r • quotientOrderReesShift k I + (quotientOrderReesShift k I y) := by + simpa only [MulOpposite.op_unop, + orderReesParameter_op_smul_eq_shift] using + (orderReesParameter_op_smul_comm k I r.unop + (quotientOrderReesShift k I y)) + +/-- The source opposite-Rees action descends to the additive two-jet +quotient. -/ +def quotientOrderReesSourceAction + (I : RightIdeal (PresentedWeyl k n)) + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) : + FilteredQuotientTwoJet k I →ₗ[k] FilteredQuotientTwoJet k I := + (quotientOrderReesTwoJetSubmodule k I).mapQ + (quotientOrderReesTwoJetSubmodule k I) + (DistribMulAction.toLinearMap k (QuotientOrderReesModule k I) r) + (by + intro x hx + exact op_smul_mem_quotientOrderReesTwoJetSubmodule k I r hx) + +@[simp] theorem quotientOrderReesSourceAction_mk + (I : RightIdeal (PresentedWeyl k n)) + (r : (OrderReesRing (n := n) k)ᵐᵒᵖ) + (x : QuotientOrderReesModule k I) : + quotientOrderReesSourceAction k I r (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (r • x) := + rfl + +/-- The inherited source-Rees scalar multiplication on the two-jet +quotient. -/ +def filteredQuotientTwoJetSourceSMul + (I : RightIdeal (PresentedWeyl k n)) : + SMul (OrderReesRing (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + ⟨fun r x => quotientOrderReesSourceAction k I r x⟩ + +/-! The scalar multiplication is deliberately *not* registered as a separate +instance. Registering it alongside the module below gives two syntactically +different routes to the same `SMul`, and under Lean 4.33 `add_smul`, +`neg_smul` and `mul_smul` then fail to rewrite goals stated through the +standalone route. The module instance supplies the action. -/ + +/-- Before scalar factorization, the module two-jet is an honest module over +the opposite source Rees ring. -/ +def filteredQuotientTwoJetSourceModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (OrderReesRing (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + letI : SMul (OrderReesRing (n := n) k)ᵐᵒᵖ (FilteredQuotientTwoJet k I) := + filteredQuotientTwoJetSourceSMul k I + Module.ofMinimalAxioms + (fun r x y => by + refine Submodule.Quotient.induction_on _ x ?_ + intro x + refine Submodule.Quotient.induction_on _ y ?_ + intro y + change Submodule.Quotient.mk (r • (x + y)) = _ + rw [smul_add] + rfl) + (fun r s x => by + refine Submodule.Quotient.induction_on _ x ?_ + intro x + change Submodule.Quotient.mk ((r + s) • x) = _ + rw [add_smul] + rfl) + (fun r s x => by + refine Submodule.Quotient.induction_on _ x ?_ + intro x + change Submodule.Quotient.mk ((r * s) • x) = _ + rw [mul_smul] + rfl) + (fun x => by + refine Submodule.Quotient.induction_on _ x ?_ + intro x + change Submodule.Quotient.mk ((1 : + (OrderReesRing (n := n) k)ᵐᵒᵖ) • x) = _ + rw [one_smul] + ) + +local instance filteredQuotientTwoJetSourceModuleInstance + (I : RightIdeal (PresentedWeyl k n)) : + Module (OrderReesRing (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + filteredQuotientTwoJetSourceModule k I + +@[simp] theorem source_op_smul_mk + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) + (x : QuotientOrderReesModule k I) : + MulOpposite.op r • (Submodule.Quotient.mk x : + FilteredQuotientTwoJet k I) = + Submodule.Quotient.mk (MulOpposite.op r • x) := + rfl + +theorem source_parameter_sq_op_smul_eq_zero + (I : RightIdeal (PresentedWeyl k n)) + (x : FilteredQuotientTwoJet k I) : + MulOpposite.op (orderReesParameter (n := n) k ^ 2) • x = 0 := by + refine Submodule.Quotient.induction_on _ x ?_ + intro x + rw [source_op_smul_mk] + rw [show MulOpposite.op (orderReesParameter (n := n) k ^ 2) = + MulOpposite.op (orderReesParameter (n := n) k) * + MulOpposite.op (orderReesParameter (n := n) k) by + apply MulOpposite.unop_injective + simp [pow_two]] + rw [mul_smul, orderReesParameter_op_smul_eq_shift, + orderReesParameter_op_smul_eq_shift] + rw [Submodule.Quotient.mk_eq_zero] + exact ⟨x, rfl⟩ + +/-- The source elements acting by zero on the module two-jet form a +two-sided ideal. -/ +def quotientOrderReesTwoJetAnnihilator + (I : RightIdeal (PresentedWeyl k n)) : + TwoSidedIdeal (OrderReesRing (n := n) k) := + TwoSidedIdeal.mk' + {r | ∀ x : FilteredQuotientTwoJet k I, MulOpposite.op r • x = 0} + (by intro x; exact zero_smul _ x) + (by + intro r s hr hs x + rw [MulOpposite.op_add, add_smul, hr x, hs x, add_zero]) + (by + intro r hr x + rw [MulOpposite.op_neg, neg_smul, hr x, neg_zero]) + (by + intro r s hs x + rw [MulOpposite.op_mul, mul_smul, hs]) + (by + intro r s hr x + rw [MulOpposite.op_mul, mul_smul, hr, smul_zero]) + +theorem orderReesTwoJetIdeal_le_moduleAnnihilator + (I : RightIdeal (PresentedWeyl k n)) : + orderReesTwoJetIdeal (n := n) k ≤ + quotientOrderReesTwoJetAnnihilator k I := by + intro r hr + rw [orderReesTwoJetIdeal, TwoSidedIdeal.mem_span_iff] at hr + apply hr (quotientOrderReesTwoJetAnnihilator k I) + intro z hz + simp only [Set.mem_singleton_iff] at hz + subst z + change ∀ x : FilteredQuotientTwoJet k I, + MulOpposite.op (orderReesParameter (n := n) k ^ 2 - 0) • x = 0 + simpa using source_parameter_sq_op_smul_eq_zero k I + +theorem source_op_smul_eq_zero_of_mem_twoJetIdeal + (I : RightIdeal (PresentedWeyl k n)) + {r : OrderReesRing (n := n) k} + (hr : r ∈ orderReesTwoJetIdeal (n := n) k) + (x : FilteredQuotientTwoJet k I) : + MulOpposite.op r • x = 0 := by + have h := orderReesTwoJetIdeal_le_moduleAnnihilator k I hr + change ∀ y : FilteredQuotientTwoJet k I, + MulOpposite.op (r - 0) • y = 0 at h + simpa using h x + +/-- Action of one opposite two-jet scalar, obtained by factoring the source +right action through the two-sided `T²` quotient. -/ +def quotientOrderReesTwoJetAction + (I : RightIdeal (PresentedWeyl k n)) + (q : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ) : + FilteredQuotientTwoJet k I →ₗ[k] FilteredQuotientTwoJet k I := + Quotient.lift + (fun r : OrderReesRing (n := n) k => + quotientOrderReesSourceAction k I (MulOpposite.op r)) + (by + intro r s hrs + apply LinearMap.ext + intro x + have hrs' : r - s ∈ orderReesTwoJetIdeal (n := n) k := + ((orderReesTwoJetIdeal (n := n) k).rel_iff r s).mp hrs + have hzero := source_op_smul_eq_zero_of_mem_twoJetIdeal k I hrs' x + rw [MulOpposite.op_sub, sub_smul] at hzero + exact sub_eq_zero.mp hzero) + q.unop + +@[simp] theorem quotientOrderReesTwoJetAction_quotient + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) : + quotientOrderReesTwoJetAction k I + (MulOpposite.op (orderReesTwoJetQuotient (n := n) k r)) = + quotientOrderReesSourceAction k I (MulOpposite.op r) := + rfl + +/-- Scalar multiplication by the opposite order-Rees two-jet. -/ +def filteredQuotientTwoJetSMul + (I : RightIdeal (PresentedWeyl k n)) : + SMul (OrderReesTwoJet (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + ⟨fun q x => quotientOrderReesTwoJetAction k I q x⟩ + +/-! As for the source action above, this scalar multiplication is not +registered as a separate instance: the module instance below is the single +route to it, so that `mul_smul` and friends rewrite. -/ + +private theorem exists_twoJet_op_representative + (q : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ) : + ∃ r : OrderReesRing (n := n) k, + q = MulOpposite.op (orderReesTwoJetQuotient (n := n) k r) := by + obtain ⟨r, hr⟩ := Quotient.mk''_surjective q.unop + refine ⟨r, ?_⟩ + rw [← MulOpposite.op_unop q] + apply congrArg MulOpposite.op + exact hr.symm + +/-- The concrete module two-jet is a right module over the order-Rees +two-jet, represented as a left module over the opposite ring. -/ +def filteredQuotientTwoJetModule + (I : RightIdeal (PresentedWeyl k n)) : + Module (OrderReesTwoJet (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + letI : SMul (OrderReesTwoJet (n := n) k)ᵐᵒᵖ (FilteredQuotientTwoJet k I) := + filteredQuotientTwoJetSMul k I + Module.ofMinimalAxioms + (fun q x y => (quotientOrderReesTwoJetAction k I q).map_add x y) + (fun q s x => by + obtain ⟨r, rfl⟩ := exists_twoJet_op_representative (n := n) k q + obtain ⟨t, rfl⟩ := exists_twoJet_op_representative (n := n) k s + change MulOpposite.op (r + t) • x = + MulOpposite.op r • x + MulOpposite.op t • x + rw [MulOpposite.op_add, add_smul]) + (fun q s x => by + obtain ⟨r, rfl⟩ := exists_twoJet_op_representative (n := n) k q + obtain ⟨t, rfl⟩ := exists_twoJet_op_representative (n := n) k s + change MulOpposite.op (t * r) • x = + MulOpposite.op r • (MulOpposite.op t • x) + rw [MulOpposite.op_mul, mul_smul]) + (fun x => by + change MulOpposite.op (1 : OrderReesRing (n := n) k) • x = x + rw [MulOpposite.op_one, one_smul]) + +noncomputable instance filteredQuotientTwoJetModuleInstance + (I : RightIdeal (PresentedWeyl k n)) : + Module (OrderReesTwoJet (n := n) k)ᵐᵒᵖ + (FilteredQuotientTwoJet k I) := + filteredQuotientTwoJetModule k I + +@[simp] theorem twoJet_quotient_op_smul_mk + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) + (x : QuotientOrderReesModule k I) : + MulOpposite.op (orderReesTwoJetQuotient (n := n) k r) • + (Submodule.Quotient.mk x : FilteredQuotientTwoJet k I) = + Submodule.Quotient.mk (MulOpposite.op r • x) := + rfl + +@[simp] theorem twoJet_op_smul_mk + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) + (x : QuotientOrderReesModule k I) : + MulOpposite.op (orderReesTwoJetQuotient (n := n) k r) • + (Submodule.Quotient.mk x : FilteredQuotientTwoJet k I) = + Submodule.Quotient.mk (MulOpposite.op r • x) := + rfl + +/-- Action of the square-zero two-jet parameter. -/ +def quotientOrderReesTwoJetCAct + (I : RightIdeal (PresentedWeyl k n)) : + FilteredQuotientTwoJet k I →ₗ[k] FilteredQuotientTwoJet k I := + quotientOrderReesTwoJetAction k I + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) + +theorem quotientOrderReesTwoJetCAct_apply + (I : RightIdeal (PresentedWeyl k n)) + (x : FilteredQuotientTwoJet k I) : + quotientOrderReesTwoJetCAct k I x = + MulOpposite.op (orderReesTwoJetParameter (n := n) k) • x := + rfl + +@[simp] theorem quotientOrderReesTwoJetCAct_mk + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) : + quotientOrderReesTwoJetCAct k I (Submodule.Quotient.mk x) = + Submodule.Quotient.mk (quotientOrderReesShift k I x) := by + rw [quotientOrderReesTwoJetCAct_apply, orderReesTwoJetParameter, + twoJet_op_smul_mk, orderReesParameter_op_smul_eq_shift] + +theorem quotientOrderReesTwoJetCAct_sq_eq_zero + (I : RightIdeal (PresentedWeyl k n)) + (x : FilteredQuotientTwoJet k I) : + quotientOrderReesTwoJetCAct k I + (quotientOrderReesTwoJetCAct k I x) = 0 := by + change MulOpposite.op (orderReesTwoJetParameter (n := n) k) • + (MulOpposite.op (orderReesTwoJetParameter (n := n) k) • x) = 0 + rw [← mul_smul] + have hc : MulOpposite.op (orderReesTwoJetParameter (n := n) k) * + MulOpposite.op (orderReesTwoJetParameter (n := n) k) = 0 := by + apply MulOpposite.unop_injective + simpa [pow_two] using orderReesTwoJetParameter_sq (n := n) k + rw [hc, zero_smul] + +/-- Exactness of the square-zero parameter on the module two-jet. -/ +theorem quotientOrderReesTwoJetCAct_ker_eq_range + (I : RightIdeal (PresentedWeyl k n)) : + LinearMap.ker (quotientOrderReesTwoJetCAct k I) = + LinearMap.range (quotientOrderReesTwoJetCAct k I) := by + apply le_antisymm + · intro q hq + refine Submodule.Quotient.induction_on _ q ?_ hq + intro x hx + rw [LinearMap.mem_ker, quotientOrderReesTwoJetCAct_mk] at hx + rw [Submodule.Quotient.mk_eq_zero] at hx + obtain ⟨y, hy⟩ := hx + have hshift : quotientOrderReesShift k I y = x := by + apply quotientOrderReesShift_injective k I + simpa [LinearMap.comp_apply] using hy + refine ⟨Submodule.Quotient.mk y, ?_⟩ + rw [quotientOrderReesTwoJetCAct_mk, hshift] + · intro q hq + obtain ⟨x, rfl⟩ := hq + rw [LinearMap.mem_ker] + exact quotientOrderReesTwoJetCAct_sq_eq_zero k I x + +/-- Specialization of the module two-jet to the actual associated graded +module. -/ +def filteredQuotientTwoJetRho + (I : RightIdeal (PresentedWeyl k n)) : + FilteredQuotientTwoJet k I →ₗ[k] OrderAssociatedGradedModule k I := + (quotientOrderReesTwoJetSubmodule k I).liftQ + (quotientOrderReesToAssociatedGraded k I) + (by + intro x hx + obtain ⟨y, rfl⟩ := hx + have hcomp := LinearMap.congr_fun + (quotientOrderReesToAssociatedGraded_comp_shift k I) + (quotientOrderReesShift k I y) + show quotientOrderReesToAssociatedGraded k I _ = 0 + simpa [LinearMap.comp_apply] using hcomp) + +@[simp] theorem filteredQuotientTwoJetRho_mk + (I : RightIdeal (PresentedWeyl k n)) + (x : QuotientOrderReesModule k I) : + filteredQuotientTwoJetRho k I (Submodule.Quotient.mk x) = + quotientOrderReesToAssociatedGraded k I x := + rfl + +theorem filteredQuotientTwoJetRho_surjective + (I : RightIdeal (PresentedWeyl k n)) : + Function.Surjective (filteredQuotientTwoJetRho k I) := by + intro g + obtain ⟨x, hx⟩ := quotientOrderReesToAssociatedGraded_surjective k I g + exact ⟨Submodule.Quotient.mk x, hx⟩ + +theorem filteredQuotientTwoJetRho_ker_eq_range_cAct + (I : RightIdeal (PresentedWeyl k n)) : + LinearMap.ker (filteredQuotientTwoJetRho k I) = + LinearMap.range (quotientOrderReesTwoJetCAct k I) := by + apply le_antisymm + · intro q hq + refine Submodule.Quotient.induction_on _ q ?_ hq + intro x hx + rw [LinearMap.mem_ker, filteredQuotientTwoJetRho_mk] at hx + have hxker : x ∈ LinearMap.ker + (quotientOrderReesToAssociatedGraded k I) := + LinearMap.mem_ker.mpr hx + rw [quotientOrderReesToAssociatedGraded_ker_eq_range_shift] at hxker + obtain ⟨y, hy⟩ := hxker + refine ⟨Submodule.Quotient.mk y, ?_⟩ + rw [quotientOrderReesTwoJetCAct_mk, hy] + · intro q hq + obtain ⟨x, rfl⟩ := hq + rw [LinearMap.mem_ker] + refine Submodule.Quotient.induction_on _ x ?_ + intro y + rw [quotientOrderReesTwoJetCAct_mk, + filteredQuotientTwoJetRho_mk] + have hcomp := LinearMap.congr_fun + (quotientOrderReesToAssociatedGraded_comp_shift k I) y + exact hcomp + +private theorem source_specialization_compatible_of_of + (I : RightIdeal (PresentedWeyl k n)) + {N M : ℕ} (q : Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I N) + (y : Stafford38.WeylFiltration.orderPiece k n M) : + (quotientOrderReesToAssociatedGraded k I + (MulOpposite.op (orderReesMonomial k M y) • + DirectSum.of + (fun L => Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I L) + N q) : OrderAssociatedGradedModule k I) = + orderReesSpecialization (n := n) k (orderReesMonomial k M y) • + (quotientOrderReesToAssociatedGraded k I + (DirectSum.of + (fun L => Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece k I L) + N q) : OrderAssociatedGradedModule k I) := by + obtain ⟨z, hz, hq⟩ := q.property + let zp : Stafford38.WeylFiltration.orderPiece k n N := ⟨z, hz⟩ + have hq' : q = Stafford38.CharacteristicFilteredQuotient.orderPieceToQuotientPiece + k I N zp := by + apply Subtype.ext + exact hq.symm + subst q + rw [orderReesMonomial_op_smul_of, + quotientOrderReesToAssociatedGraded_of, + quotientOrderReesToAssociatedGraded_of, + orderReesSpecialization_monomial] + change Stafford38.CharacteristicAssociatedGradedModule.orderAssociatedGradedOf + k I (M + N) + (Stafford38.CharacteristicFilteredQuotient.orderPieceToQuotientGraded + k I (M + N) + ⟨(zp : PresentedWeyl k n) * y, + by simpa [Nat.add_comm] using + Stafford38.WeylFiltration.mul_mem_orderPiece k + zp.property y.property⟩) = + (Stafford38.WeylAssociatedGraded.principalComponentOnPiece k + (@Stafford38.WeylFiltration.orderWeight n) M y : + Stafford38.Characteristic.SymbolRing k n) • + Stafford38.CharacteristicAssociatedGradedModule.orderAssociatedGradedOf + k I N + (Stafford38.CharacteristicFilteredQuotient.orderPieceToQuotientGraded + k I N zp) + rw [Stafford38.CharacteristicAssociatedGradedModule.smul_orderAssociatedGradedOf_mk_eq_of_mul] + apply (orderAssociatedGradedLinearEquivCharacteristic k I).injective + rw [orderAssociatedGradedLinearEquivCharacteristic_of_mk, + orderAssociatedGradedLinearEquivCharacteristic_of_mk] + congr 1 + change Stafford38.WeylLeadingSymbol.presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight n) (M + N) + ((zp : PresentedWeyl k n) * (y : PresentedWeyl k n)) = + Stafford38.WeylLeadingSymbol.presentedPrincipalComponent k + (@Stafford38.WeylFiltration.orderWeight n) (N + M) + ((zp : PresentedWeyl k n) * (y : PresentedWeyl k n)) + rw [Nat.add_comm M N] + +private theorem source_specialization_compatible_directSum + (I : RightIdeal (PresentedWeyl k n)) + (s : OppositeOrderPieceSum (n := n) k) + (x : QuotientOrderReesModule k I) : + (quotientOrderReesToAssociatedGraded k I + ((orderPieceOpDirectSumEquivReesOp (n := n) k s) • x) : + OrderAssociatedGradedModule k I) = + orderReesSpecialization (n := n) k + (orderPieceOpDirectSumEquivReesOp (n := n) k s).unop • + (quotientOrderReesToAssociatedGraded k I x : + OrderAssociatedGradedModule k I) := by + induction s using DirectSum.induction_on with + | zero => simp + | of M y => + induction x using DirectSum.induction_on with + | zero => simp + | of N q => + let yp : Stafford38.WeylFiltration.orderPiece k n M := + ⟨y.val.unop, + (mem_orderPieceOp_iff (n := n) k M y.val).mp y.property⟩ + rw [show orderPieceOpDirectSumEquivReesOp (n := n) k + (DirectSum.of + (fun L => CharacteristicFilteredQuotientReesAction.orderPieceOp + (n := n) k L) M y) = + orderPieceOpToReesOp (n := n) k M y from + orderPieceOpDirectSumToReesOp_of (n := n) k M y] + change (quotientOrderReesToAssociatedGraded k I + (MulOpposite.op (orderReesMonomial k M yp) • + DirectSum.of + (fun L => + Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece + k I L) N q) : + OrderAssociatedGradedModule k I) = + orderReesSpecialization (n := n) k + (orderReesMonomial k M yp) • + (quotientOrderReesToAssociatedGraded k I + (DirectSum.of + (fun L => + Stafford38.CharacteristicFilteredQuotient.quotientOrderPiece + k I L) N q) : + OrderAssociatedGradedModule k I) + exact source_specialization_compatible_of_of k I q yp + | add x y hx hy => + simpa [smul_add, map_add] using + congrArg₂ (fun p q => p + q) hx hy + | add s t hs ht => + simpa [map_add, add_smul] using + congrArg₂ (fun p q => p + q) hs ht + +/-- The source order-Rees action specializes to the symbol-ring action on +the actual associated graded module. -/ +theorem quotientOrderReesToAssociatedGraded_action_compatibility + (I : RightIdeal (PresentedWeyl k n)) + (r : OrderReesRing (n := n) k) + (x : QuotientOrderReesModule k I) : + (quotientOrderReesToAssociatedGraded k I + (MulOpposite.op r • x) : OrderAssociatedGradedModule k I) = + orderReesSpecialization (n := n) k r • + (quotientOrderReesToAssociatedGraded k I x : + OrderAssociatedGradedModule k I) := by + let s := (orderPieceOpDirectSumEquivReesOp (n := n) k).symm + (MulOpposite.op r) + have hs := source_specialization_compatible_directSum k I s x + have heq : orderPieceOpDirectSumEquivReesOp (n := n) k s = + MulOpposite.op r := by + exact (orderPieceOpDirectSumEquivReesOp (n := n) k).apply_symm_apply _ + rw [heq] at hs + simpa using hs + +/-- The factored two-jet action and the actual associated-graded +specialization are compatible. -/ +theorem filteredQuotientTwoJetRho_action_compatibility + (I : RightIdeal (PresentedWeyl k n)) + (b : OrderReesTwoJet (n := n) k) + (m : FilteredQuotientTwoJet k I) : + filteredQuotientTwoJetRho k I (MulOpposite.op b • m) = + orderReesTwoJetSpecialization (n := n) k b • + filteredQuotientTwoJetRho k I m := by + obtain ⟨r, hr⟩ := exists_twoJet_op_representative (n := n) k + (MulOpposite.op b) + have hb : b = orderReesTwoJetQuotient (n := n) k r := by + simpa using congrArg MulOpposite.unop hr + rw [hb] + refine Submodule.Quotient.induction_on _ m ?_ + intro x + rw [twoJet_op_smul_mk, filteredQuotientTwoJetRho_mk, + filteredQuotientTwoJetRho_mk, + orderReesTwoJetSpecialization_quotient] + exact quotientOrderReesToAssociatedGraded_action_compatibility k I r x + + +end + +end Stafford38.CharacteristicFilteredQuotientTwoJet diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryExhaustion.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryExhaustion.lean new file mode 100644 index 0000000000..c20873e362 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryExhaustion.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryExhaustion +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalPages + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.targetBoundaryMap FilteredTwoTerm.targetBoundaryMap_mk FilteredTwoTerm.targetBoundaryMap_surjective FilteredTwoTerm.targetBoundaryMap_ker_mono FilteredTwoTerm.totalBoundaryMap FilteredTwoTerm.totalBoundaryMap_lof FilteredTwoTerm.totalBoundaryMap_surjective FilteredTwoTerm.totalBoundaryMap_ker_mono FilteredTwoTerm.totalBoundaryMap_eventually_zero) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryNaturality.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryNaturality.lean new file mode 100644 index 0000000000..6af7124a95 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermBoundaryNaturality.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermBoundaryNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermBoundaryExhaustion + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.PageOperator.targetBoundaryMap_naturality FilteredTwoTerm.PageOperator.totalBoundaryMap_naturality) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageActions.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageActions.lean new file mode 100644 index 0000000000..775748bf47 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageActions.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPages + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.PageOperator FilteredTwoTerm.PageOperator.comp FilteredTwoTerm.PageOperator.reverseComp FilteredTwoTerm.PageOperator.commute_apply FilteredTwoTerm.PageOperator.sourceRestricted FilteredTwoTerm.PageOperator.sourceMap FilteredTwoTerm.PageOperator.sourceMap_mk FilteredTwoTerm.PageOperator.sourcePageCast FilteredTwoTerm.PageOperator.sourcePageCast_mk FilteredTwoTerm.PageOperator.targetRestricted FilteredTwoTerm.PageOperator.targetMap FilteredTwoTerm.PageOperator.targetMap_mk FilteredTwoTerm.PageOperator.targetPageCast FilteredTwoTerm.PageOperator.targetPageCast_mk FilteredTwoTerm.PageOperator.targetMapAtDrop FilteredTwoTerm.PageOperator.targetMapAtDrop_mk FilteredTwoTerm.PageOperator.targetMapAtDrop_eq_cast_targetMap FilteredTwoTerm.PageOperator.targetMapAtDrop_drop FilteredTwoTerm.PageOperator.targetMap_drop FilteredTwoTerm.PageOperator.SameSymbol FilteredTwoTerm.PageOperator.sourceMap_eq_of_sameSymbol FilteredTwoTerm.PageOperator.targetMap_eq_of_sameSymbol FilteredTwoTerm.PageOperator.targetMapAtDrop_eq_of_sameSymbol) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageEquivalences.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageEquivalences.lean new file mode 100644 index 0000000000..3a743d7cec --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPageEquivalences.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPages + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.sourceSuccMap FilteredTwoTerm.sourceSuccMap_mk FilteredTwoTerm.sourceSuccKernelMap FilteredTwoTerm.sourceSuccEquivKerDrop FilteredTwoTerm.targetSuccMap FilteredTwoTerm.targetSuccMap_surjective FilteredTwoTerm.ker_targetSuccMap_eq_range_drop FilteredTwoTerm.targetCokernelMap FilteredTwoTerm.targetSuccEquivCokerDrop) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPages.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPages.lean new file mode 100644 index 0000000000..b202a23bf5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermPages.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermPages + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm FilteredTwoTerm.cycles FilteredTwoTerm.boundaries FilteredTwoTerm.next_le FilteredTwoTerm.boundaries_le FilteredTwoTerm.SourcePage FilteredTwoTerm.TargetPage FilteredTwoTerm.drop FilteredTwoTerm.drop_mk FilteredTwoTerm.cycles_succ_le FilteredTwoTerm.boundaries_le_succ FilteredTwoTerm.drop_mk_eq_zero_of_mem_cycles_succ FilteredTwoTerm.exists_cycles_succ_rep_of_drop_mk_eq_zero FilteredTwoTerm.mem_boundaries_succ_rep FilteredTwoTerm.exists_mem_boundaries_of_surjective) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermSuccessorNaturality.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermSuccessorNaturality.lean new file mode 100644 index 0000000000..d5125c0bfe --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermSuccessorNaturality.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermSuccessorNaturality +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalActions + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.PageOperator.sourceTotalSuccMap_naturality FilteredTwoTerm.PageOperator.targetTotalSuccMap_naturality) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalActions.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalActions.lean new file mode 100644 index 0000000000..f8c079a179 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalActions.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalActions +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermTotalPages + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.PageOperator.sourceTotalMap FilteredTwoTerm.PageOperator.targetTotalMap FilteredTwoTerm.PageOperator.sourceTotalMap_lof FilteredTwoTerm.PageOperator.targetTotalMap_lof FilteredTwoTerm.PageOperator.totalDrop_intertwines FilteredTwoTerm.PageOperator.sourceTotalMap_commute_of_commutator_lowers FilteredTwoTerm.PageOperator.targetTotalMap_commute_of_commutator_lowers) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalPages.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalPages.lean new file mode 100644 index 0000000000..39cf5208fa --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredTwoTermTotalPages.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.FilteredTwoTermTotalPages +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageEquivalences +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredTwoTermPageActions + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.FilteredTwoTermPages + +export AlgebraicAnalysis.FilteredTwoTermPages (FilteredTwoTerm.SourceTotal FilteredTwoTerm.TargetTotal FilteredTwoTerm.totalDrop FilteredTwoTerm.totalDrop_lof FilteredTwoTerm.totalDrop_lof_mk FilteredTwoTerm.sourceTotalSuccMap FilteredTwoTerm.totalSourceSuccMap_injective FilteredTwoTerm.range_totalSourceSuccMap FilteredTwoTerm.sourceTotalSuccEquivKerDrop FilteredTwoTerm.targetTotalSuccMap FilteredTwoTerm.ker_totalTargetSuccMap FilteredTwoTerm.targetTotalSuccEquivCokerDrop) + +end Stafford38.Characteristic.FilteredTwoTermPages diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/FilteredVanishing.lean b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredVanishing.lean new file mode 100644 index 0000000000..36d22d00b7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/FilteredVanishing.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotient + +/-! +# Vanishing reflected by an exhaustive filtered quotient + +For the actual quotient `A / I` with its induced differential-order +filtration, vanishing of every associated graded piece forces the quotient +itself to vanish. The proof is internal to the filtration: degree zero uses +that its strict-lower piece is zero, and the successor step lowers the degree +by one. Exhaustivity of the PBW order filtration then reaches every quotient +class. +-/ + +namespace Stafford38.CharacteristicFilteredVanishing + +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- If every associated graded piece of the induced order filtration is +subsingleton, then every filtration piece is zero. The induction explicitly +separates the degree-zero and successor cases. -/ +theorem quotientOrderPiece_eq_bot_of_all_graded_subsingleton + (I : RightIdeal (PresentedWeyl k n)) + (hgraded : ∀ N, Subsingleton (QuotientOrderGradedPiece k I N)) : + ∀ N, quotientOrderPiece k I N = ⊥ := by + intro N + induction N with + | zero => + apply le_antisymm + · intro q hq + let qN : quotientOrderPiece k I 0 := ⟨q, hq⟩ + have hmk : + (Submodule.Quotient.mk qN : QuotientOrderGradedPiece k I 0) = 0 := + Subsingleton.elim _ _ + have hlower : qN ∈ + (quotientOrderStrictLowerPiece k I 0).comap + (quotientOrderPiece k I 0).subtype := + (Submodule.Quotient.mk_eq_zero _).mp hmk + change q ∈ quotientOrderStrictLowerPiece k I 0 at hlower + simpa [quotientOrderStrictLowerPiece, presentedStrictLowerPiece] using hlower + · exact bot_le + | succ N ih => + apply le_antisymm + · intro q hq + let qN : quotientOrderPiece k I (N + 1) := ⟨q, hq⟩ + have hmk : + (Submodule.Quotient.mk qN : + QuotientOrderGradedPiece k I (N + 1)) = 0 := + Subsingleton.elim _ _ + have hlower : qN ∈ + (quotientOrderStrictLowerPiece k I (N + 1)).comap + (quotientOrderPiece k I (N + 1)).subtype := + (Submodule.Quotient.mk_eq_zero _).mp hmk + change q ∈ quotientOrderStrictLowerPiece k I (N + 1) at hlower + have hqN : q ∈ quotientOrderPiece k I N := by + simpa [quotientOrderStrictLowerPiece, presentedStrictLowerPiece, + quotientOrderPiece] using hlower + rw [ih] at hqN + exact hqN + · exact bot_le + +/-- Vanishing of every actual associated graded piece reflects to the actual +filtered quotient because the induced order filtration is exhaustive. -/ +theorem filteredRightQuotient_subsingleton_of_all_graded_subsingleton + (I : RightIdeal (PresentedWeyl k n)) + (hgraded : ∀ N, Subsingleton (QuotientOrderGradedPiece k I N)) : + Subsingleton (FilteredRightQuotient k I) := by + have hzero : ∀ q : FilteredRightQuotient k I, q = 0 := by + intro q + refine Submodule.Quotient.induction_on _ q ?_ + intro a + obtain ⟨N, hN⟩ := exists_mem_orderPiece k a + have hpiece : + (rightIdealKSubmodule k I).mkQ a ∈ quotientOrderPiece k I N := + ⟨a, hN, rfl⟩ + rw [quotientOrderPiece_eq_bot_of_all_graded_subsingleton k I hgraded] at hpiece + exact hpiece + exact ⟨fun q r => (hzero q).trans (hzero r).symm⟩ + +/-- Consequently the existing regular-right-module quotient is zero as well, +via its canonical linear equivalence with the filtered quotient. -/ +theorem rightQuotient_subsingleton_of_all_graded_subsingleton + (I : RightIdeal (PresentedWeyl k n)) + (hgraded : ∀ N, Subsingleton (QuotientOrderGradedPiece k I N)) : + Subsingleton (RightQuotient I) := by + letI : Subsingleton (FilteredRightQuotient k I) := + filteredRightQuotient_subsingleton_of_all_graded_subsingleton k I hgraded + constructor + intro q r + apply (filteredRightQuotientEquivRightQuotient k I).symm.injective + exact Subsingleton.elim _ _ + + +end + +end Stafford38.CharacteristicFilteredVanishing diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/GabberGlobalAssembly.lean b/LeanPool/Stafford38/Stafford38/Characteristic/GabberGlobalAssembly.lean new file mode 100644 index 0000000000..af79be68e8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/GabberGlobalAssembly.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.BGab001CoefficientFieldTrace +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGabberInvolutivityInterface + +/-! +# Gabber involutivity for Weyl quotients + +Apply the Artinian-local commutator theorem to the localized two-block Rees +deformation at each minimal prime. Contract bracket membership, then intersect +the minimal primes. The final theorem is field-generic and has no literature +or project assumption. The opposite-ring lifts are swapped explicitly to +preserve the right-module bracket orientation. + + +## References and proof context + +[Gab81] Ofer Gabber, *The Integrability of the Characteristic Variety*, American Journal of Mathematics 103 (1981), no. 3, 445–468. +https://doi.org/10.2307/2374101 + +This is the classical theorem implemented for cyclic Weyl quotients. Its exact radical-involutivity interface is proved here; see docs/literature.md and docs/proof-guide.md. +-/ + +namespace Stafford38.Characteristic.GabberGlobalAssembly + +open Stafford38.Characteristic.BGab001CoefficientFieldTrace +open Stafford38.Characteristic.ConcreteInducedZAction +open Stafford38.Characteristic.ConcreteEquation33SourceMatrices +open Stafford38.Characteristic.ConcreteLocalizedTwoBlockSpecialFibre +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.LocalizedTwoBlockModuleExactness +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.WeylIteratedEquivalence +open Stafford38.EulerSurjectivity + +noncomputable section +universe u + +theorem quotient_power_artinian + (R : Type u) [CommRing R] [IsLocalRing R] [IsNoetherianRing R] + (q : ℕ) (hq : 0 < q) : + IsArtinianRing (R ⧸ (IsLocalRing.maximalIdeal R) ^ q) := by + let m := IsLocalRing.maximalIdeal R + have hp : m ^ q ≠ ⊤ := ne_top_of_le_ne_top (IsLocalRing.maximalIdeal.isMaximal R).ne_top + (Ideal.pow_le_self hq.ne') + letI : Nontrivial (R ⧸ m ^ q) := Ideal.Quotient.nontrivial_iff.mpr hp + letI : IsLocalRing (R ⧸ m ^ q) := + IsLocalRing.of_surjective' (Ideal.Quotient.mk (m ^ q)) Ideal.Quotient.mk_surjective + apply (isArtinianRing_iff_isNilpotent_maximalIdeal (R ⧸ m ^ q)).mpr + refine ⟨q, ?_⟩ + rw [← IsLocalRing.map_maximalIdeal_of_surjective + (Ideal.Quotient.mk (m ^ q)) Ideal.Quotient.mk_surjective, ← Ideal.map_pow] + exact Ideal.map_quotient_self (m ^ q) + +variable (k : Type u) [Field k] [CharZero k] {n : ℕ} +variable (I : RightIdeal (PresentedWeyl k n)) +variable (P : Ideal (SymbolRing k n)) [P.IsPrime] + +local notation "D" => filteredQuotientTwoJetTraceData k I +local notation "S" => P.primeCompl +local notation "R" => Localization S +local notation "G" => LocalizedModule S (OrderAssociatedGradedModule k I) +local notation "Wₗ" => LocalizedDeformationModule D S +local notation "C" => LocalizedTwoBlockRing D S + +variable [hOre : OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) P.primeCompl)] + +include hOre in +theorem localized_cofactor_mem + (q : ℕ) (hq : 0 < q) + (hpow : IsLocalRing.maximalIdeal R ^ q ≤ Module.annihilator R G) + [Module.Finite R G] [Nontrivial G] + (x y z : C q) + (hx : localizedTwoBlockSpecialization D S q x ∈ + (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk (localizedDoubledPower S q))) + (hy : localizedTwoBlockSpecialization D S q y ∈ + (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk (localizedDoubledPower S q))) + (hxy : x * y - y * x = + (concreteLeftPrincipalParameterReduction k I S q).parameter * z) : + localizedTwoBlockSpecialization D S q z ∈ + (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk (localizedDoubledPower S q)) := by + let H := localizedDoubledPower S q + let Rq := R ⧸ H + have hH : H = (IsLocalRing.maximalIdeal R) ^ (q + q) := by + exact (pow_add (IsLocalRing.maximalIdeal R) q q).symm + have hproper : H ≠ ⊤ := by + rw [hH] + exact ne_top_of_le_ne_top (IsLocalRing.maximalIdeal.isMaximal R).ne_top + (Ideal.pow_le_self (by omega)) + letI : Nontrivial Rq := Ideal.Quotient.nontrivial_iff.mpr hproper + letI : IsLocalRing Rq := IsLocalRing.of_surjective' + (Ideal.Quotient.mk H) Ideal.Quotient.mk_surjective + letI : IsArtinianRing Rq := by + dsimp [Rq] + rw [hH] + exact quotient_power_artinian R (q + q) (by omega) + letI : Module Rq G := localizedDoubledPowerQuotientModule S q hpow + letI : IsScalarTower R Rq G := by + constructor + intro a b v + induction b using Quotient.inductionOn' with + | _ b => exact mul_smul a b v + letI : Module.Finite Rq G := Module.Finite.of_restrictScalars_finite R Rq G + letI : Module (C q) Wₗ := localizedTwoBlockModule D S q hpow + let E := concreteLeftPrincipalParameterReduction k I S q + let rho := localizedDoubledPowerModuleSpecialization D S q hpow + have hparam : parameterAct (W := Wₗ) E.parameter = localizedCAct D S := by + ext w + exact localizedTwoBlock_parameter_smul D S q hpow w + have hact : ∀ a w, rho (a • w) = E.modParameter a • rho w := + localizedDoubledPowerModuleSpecialization_action D S q hpow + have hker : AddMonoidHom.ker rho = AddMonoidHom.range (parameterAct (W := Wₗ) E.parameter) := by + rw [hparam] + exact localizedDoubledPowerModuleSpecialization_ker D S q hpow + have hexact : AddMonoidHom.ker (parameterAct (W := Wₗ) E.parameter) = + AddMonoidHom.range (parameterAct (W := Wₗ) E.parameter) := by + rw [hparam] + exact localizedCAct_ker_eq_range D S + have hc2 : E.parameter * E.parameter = 0 := by + rw [← pow_two] + change ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op (orderReesTwoJetParameter (n := n) k)))) ^ 2 = 0 + exact localizedTwoBlock_parameter_sq D S q + have hmax : (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk H) = + IsLocalRing.maximalIdeal Rq := + IsLocalRing.map_maximalIdeal_of_surjective _ Ideal.Quotient.mk_surjective + rw [hmax] at hx hy ⊢ + exact artinian_local_cofactor_mem_maximalIdeal k E rho + (localizedDoubledPowerModuleSpecialization_surjective D S q hpow) + hact hker hexact hc2 x y z hx hy hxy + +omit hOre in +theorem minimalPrime_isInvolutive + (hP : P ∈ (Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I)).minimalPrimes) : IsInvolutive P := by + obtain ⟨h, core⟩ := exists_concrete_localizedPreArtinianCore k I P hP + letI := h + letI : Nontrivial G := core.fibre_nontrivial + letI : IsNoetherian R G := + (isFiniteLength_iff_isNoetherian_isArtinian.mp core.fibre_finiteLength).1 + obtain ⟨q, hq⟩ := core.annihilatingPower + have hpow : IsLocalRing.maximalIdeal R ^ (q + 1) ≤ Module.annihilator R G := + (Ideal.pow_le_pow_right (Nat.le_succ q)).trans hq + intro f hf g hg + obtain ⟨a, b, z, ha, hb, hab, hz⟩ := + RightSquareZeroTraceData.exists_lifts_commutator_factor k _ _ D f g + let φ : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ →+* C (q + 1) := + ((localizedTwoBlockIdeal D S (q + 1)).ringCon.mk').comp + OreLocalization.numeratorRingHom + let x := φ (MulOpposite.op b) + let y := φ (MulOpposite.op a) + let zq := φ (MulOpposite.op z) + let H := localizedDoubledPower S (q + 1) + have hspec (v : OrderReesTwoJet (n := n) k) : + localizedTwoBlockSpecialization D S (q + 1) (φ (MulOpposite.op v)) = + Ideal.Quotient.mk H (algebraMap (SymbolRing k n) R ((D).pi v)) := by + rw [show φ (MulOpposite.op v) = + (localizedTwoBlockIdeal D S (q + 1)).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op v)) from rfl, + localizedTwoBlockSpecialization_mk] + change Ideal.Quotient.mk H (localizedOppositeSpecialization D S + (OreLocalization.numeratorRingHom (MulOpposite.op v))) = _ + exact congrArg (Ideal.Quotient.mk H) + (localizedOppositeSpecialization_numerator D S (MulOpposite.op v)) + have hx : localizedTwoBlockSpecialization D S (q + 1) x ∈ + (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk H) := by + rw [show x = φ (MulOpposite.op b) from rfl, hspec, hb] + exact Ideal.mem_map_of_mem _ ((IsLocalization.AtPrime.to_map_mem_maximal_iff R P g).mpr hg) + have hy : localizedTwoBlockSpecialization D S (q + 1) y ∈ + (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk H) := by + rw [show y = φ (MulOpposite.op a) from rfl, hspec, ha] + exact Ideal.mem_map_of_mem _ ((IsLocalization.AtPrime.to_map_mem_maximal_iff R P f).mpr hf) + have hop : MulOpposite.op b * MulOpposite.op a - MulOpposite.op a * MulOpposite.op b = + MulOpposite.op (D).c * MulOpposite.op z := by + apply MulOpposite.unop_injective + change a * b - b * a = z * (D).c + change a * b - b * a = (D).c * z at hab + exact hab.trans ((D).c_center.comm z).eq + have hxy : x * y - y * x = + (concreteLeftPrincipalParameterReduction k I S (q + 1)).parameter * zq := by + have hparam : (concreteLeftPrincipalParameterReduction k I S (q + 1)).parameter = + φ (MulOpposite.op (D).c) := rfl + rw [hparam] + have hh := congrArg φ hop + simpa only [map_sub, map_mul] using hh + have hlocal := localized_cofactor_mem k I P (q + 1) (by omega) hpow x y zq hx hy hxy + rw [show zq = φ (MulOpposite.op z) from rfl, hspec, hz, + filteredQuotientTwoJetTraceData_bracket] at hlocal + have hHle : H ≤ IsLocalRing.maximalIdeal R := + Ideal.mul_le_left.trans (Ideal.pow_le_self (by omega)) + have hneg : algebraMap (SymbolRing k n) R (-poissonBracket f g) ∈ + IsLocalRing.maximalIdeal R := by + have hc := (Ideal.mem_comap).mpr hlocal + rw [Ideal.comap_map_of_surjective (Ideal.Quotient.mk H) + Ideal.Quotient.mk_surjective, ← RingHom.ker_eq_comap_bot, + Ideal.mk_ker, sup_eq_left.mpr hHle] at hc + exact hc + exact (P.neg_mem_iff).mp ((IsLocalization.AtPrime.to_map_mem_maximal_iff R P _).mp hneg) + +omit hOre in +theorem associatedGraded_radical_isInvolutive : + IsInvolutive (Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I)).radical := by + let J := Module.annihilator (SymbolRing k n) (OrderAssociatedGradedModule k I) + intro f hf g hg + rw [← J.sInf_minimalPrimes] + apply Ideal.mem_sInf.mpr + intro P hP + letI : P.IsPrime := hP.1.1 + have hle : J.radical ≤ P := hP.1.1.radical_le_iff.mpr hP.1.2 + exact minimalPrime_isInvolutive k I P hP f (hle hf) g (hle hg) + +theorem weylAssociatedGradedRadicalInvolutivity : + Stafford38.Characteristic.CanonicalGabberInvolutivityInterface.WeylAssociatedGradedRadicalInvolutivity.{u} := by + intro k _ _ n I + exact associatedGraded_radical_isInvolutive k I + + +end +end Stafford38.Characteristic.GabberGlobalAssembly diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportDescent.lean b/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportDescent.lean new file mode 100644 index 0000000000..2590f1b197 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportDescent.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Geometric points and support after algebraic closure + +For finitely many polynomial variables over an arbitrary field, a proper +ideal has a common zero in the algebraic closure. This file records the +result with the coefficient map and its map/comap consequences explicit. + +The proof chooses a maximal ideal above the given ideal, uses Zariski's lemma +to make its residue field algebraic over the ground field, and embeds that +residue field into the algebraic closure. It does not use characteristic +varieties, Gabber's theorem, or asymptotic geometry. +-/ + +namespace Stafford38.Characteristic.GeometricSupportDescent + +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.WeylIteratedEquivalence +open Stafford38.EulerSurjectivity + +noncomputable section + +variable {k : Type*} [Field k] +variable {σ : Type*} [Finite σ] + +/-- A proper ideal in a finite-variable polynomial ring has a common zero in +the algebraic closure of the coefficient field. -/ +theorem exists_algebraicClosure_zero_of_ne_top + (J : Ideal (MvPolynomial σ k)) (hJ : J ≠ ⊤) : + ∃ q : σ → AlgebraicClosure k, + q ∈ MvPolynomial.zeroLocus (AlgebraicClosure k) + (J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ)) := by + obtain ⟨M, hMmax, hJM⟩ := Ideal.exists_le_maximal J hJ + letI : M.IsMaximal := hMmax + let Q := MvPolynomial σ k ⧸ M + letI : Field Q := Ideal.Quotient.field M + letI : Module.IsTorsionFree k Q := + Module.isTorsionFree_iff_algebraMap_injective.mpr + (MvPolynomial.quotient_mk_comp_C_injective σ k M hMmax.ne_top) + have hIntegral : + RingHom.IsIntegral + ((Ideal.Quotient.mk M).comp (MvPolynomial.C : k →+* MvPolynomial σ k)) := + MvPolynomial.comp_C_integral_of_surjective_of_isJacobsonRing + (Ideal.Quotient.mk M) Ideal.Quotient.mk_surjective + letI : Algebra.IsIntegral k Q := ⟨hIntegral⟩ + letI : Algebra.IsAlgebraic k Q := Algebra.IsIntegral.isAlgebraic + let φ : Q →ₐ[k] AlgebraicClosure k := IsAlgClosed.lift + let q : σ → AlgebraicClosure k := fun i => φ (Ideal.Quotient.mk M (MvPolynomial.X i)) + refine ⟨q, (mem_zeroLocus_map_iff J q).2 ?_⟩ + intro f hf + let ψ : MvPolynomial σ k →+* AlgebraicClosure k := + φ.toRingHom.comp (Ideal.Quotient.mk M) + have hψ : ψ f = 0 := by + change φ (Ideal.Quotient.mk M f) = 0 + rw [Ideal.Quotient.eq_zero_iff_mem.mpr (hJM hf), map_zero] + have hcoeff : ψ.comp MvPolynomial.C = + algebraMap k (AlgebraicClosure k) := by + ext a + change φ (Ideal.Quotient.mk M (MvPolynomial.C a)) = + algebraMap k (AlgebraicClosure k) a + rw [show Ideal.Quotient.mk M (MvPolynomial.C a) = algebraMap k Q a from rfl] + exact φ.commutes a + rw [MvPolynomial.map_mvPolynomial_eq_eval₂ ψ] at hψ + rw [hcoeff] at hψ + simpa [ψ, q] using hψ + +/-- Over the algebraic closure, geometric emptiness is exactly the unit-ideal +condition on the original ground-field ideal. -/ +theorem algebraicClosure_zeroLocus_eq_empty_iff + (J : Ideal (MvPolynomial σ k)) : + MvPolynomial.zeroLocus (AlgebraicClosure k) + (J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ)) = ∅ ↔ + J = ⊤ := by + constructor + · intro hzero + by_contra hJ + obtain ⟨q, hq⟩ := exists_algebraicClosure_zero_of_ne_top J hJ + rw [hzero] at hq + exact hq + · rintro rfl + change MvPolynomial.zeroLocus (AlgebraicClosure k) + ((⊤ : Ideal (MvPolynomial σ k)).map + (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ)) = + (⊥ : Set (σ → AlgebraicClosure k)) + rw [Ideal.map_top, MvPolynomial.zeroLocus_top] + +/-- Scalar extension to the algebraic closure reflects and preserves the +unit ideal for finite-variable polynomial rings. -/ +theorem map_scalarPolynomialMap_eq_top_iff + (J : Ideal (MvPolynomial σ k)) : + J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ) = ⊤ ↔ + J = ⊤ := by + constructor + · intro hmap + apply (algebraicClosure_zeroLocus_eq_empty_iff J).mp + rw [hmap] + exact MvPolynomial.zeroLocus_top + · rintro rfl + exact Ideal.map_top _ + +/-- A nonempty ground-field prime-spectrum zero locus yields a geometric +point after passing to the algebraic closure. -/ +theorem exists_algebraicClosure_zero_of_mem_primeZeroLocus + (J : Ideal (MvPolynomial σ k)) + (p : PrimeSpectrum (MvPolynomial σ k)) + (hp : p ∈ PrimeSpectrum.zeroLocus (J : Set (MvPolynomial σ k))) : + ∃ q : σ → AlgebraicClosure k, + q ∈ MvPolynomial.zeroLocus (AlgebraicClosure k) + (J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ)) := by + apply exists_algebraicClosure_zero_of_ne_top J + intro hJ + subst J + exact p.2.ne_top (by simpa using hp) + +/-- A geometric point gives a prime of the original polynomial ring by +contracting its evaluation kernel. The displayed equality records the exact +map/comap orientation. -/ +def groundPrimeOfAlgebraicClosurePoint (q : σ → AlgebraicClosure k) : + PrimeSpectrum (MvPolynomial σ k) := + PrimeSpectrum.comap (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ) + (MvPolynomial.pointToPoint q) + +theorem groundPrimeOfAlgebraicClosurePoint_asIdeal + (q : σ → AlgebraicClosure k) : + (groundPrimeOfAlgebraicClosurePoint (k := k) q).asIdeal = + (MvPolynomial.vanishingIdeal (AlgebraicClosure k) {q}).comap + (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ) := + rfl + +/-- Conversely, a geometric zero of the extended ideal contracts to a prime +of the ground polynomial ring containing the original ideal. -/ +theorem groundPrimeOfAlgebraicClosurePoint_mem_zeroLocus + (J : Ideal (MvPolynomial σ k)) (q : σ → AlgebraicClosure k) + (hq : q ∈ MvPolynomial.zeroLocus (AlgebraicClosure k) + (J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ))) : + groundPrimeOfAlgebraicClosurePoint (k := k) q ∈ + PrimeSpectrum.zeroLocus (J : Set (MvPolynomial σ k)) := by + rw [PrimeSpectrum.mem_zeroLocus] + intro f hf + change scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ f ∈ + MvPolynomial.vanishingIdeal (AlgebraicClosure k) {q} + rw [MvPolynomial.mem_vanishingIdeal_singleton_iff] + exact hq _ (Ideal.mem_map_of_mem _ hf) + +/-- Thus nonemptiness of the prime-spectrum support and nonemptiness of the +algebraic-closure geometric zero locus are equivalent. -/ +theorem primeZeroLocus_nonempty_iff_algebraicClosure_zeroLocus_nonempty + (J : Ideal (MvPolynomial σ k)) : + Set.Nonempty (PrimeSpectrum.zeroLocus (J : Set (MvPolynomial σ k))) ↔ + Set.Nonempty (MvPolynomial.zeroLocus (AlgebraicClosure k) + (J.map (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) σ))) := by + constructor + · rintro ⟨p, hp⟩ + exact exists_algebraicClosure_zero_of_mem_primeZeroLocus J p hp + · rintro ⟨q, hq⟩ + exact ⟨groundPrimeOfAlgebraicClosurePoint (k := k) q, + groundPrimeOfAlgebraicClosurePoint_mem_zeroLocus J q hq⟩ + +/-- Project-facing form: a proper order initial ideal has a geometric point +after coefficient extension to the algebraic closure. -/ +theorem exists_algebraicClosure_orderInitialZero_of_ne_top + {n : ℕ} (I : RightIdeal (PresentedWeyl k n)) + (hI : orderInitialIdeal k I ≠ ⊤) : + ∃ q : PhaseVar n → AlgebraicClosure k, + q ∈ MvPolynomial.zeroLocus (AlgebraicClosure k) + ((orderInitialIdeal k I).map + (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) (PhaseVar n))) := + exists_algebraicClosure_zero_of_ne_top (orderInitialIdeal k I) hI + +/-- The literal prime-spectrum order support is nonempty exactly when the +extended order initial ideal has an algebraic-closure-valued point. -/ +theorem orderCharacteristicSupport_nonempty_iff_geometric_nonempty + {n : ℕ} (I : RightIdeal (PresentedWeyl k n)) : + Set.Nonempty (orderCharacteristicSupport k I) ↔ + Set.Nonempty (MvPolynomial.zeroLocus (AlgebraicClosure k) + ((orderInitialIdeal k I).map + (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) (PhaseVar n)))) := by + rw [orderCharacteristicSupport_eq_zeroLocus] + exact primeZeroLocus_nonempty_iff_algebraicClosure_zeroLocus_nonempty + (orderInitialIdeal k I) + +/-- Geometric emptiness over the algebraic closure descends all the way to +the unit order initial ideal and hence to empty prime-spectrum support. -/ +theorem geometric_orderInitialZeroLocus_empty_iff_support_empty + {n : ℕ} (I : RightIdeal (PresentedWeyl k n)) : + MvPolynomial.zeroLocus (AlgebraicClosure k) + ((orderInitialIdeal k I).map + (scalarPolynomialMap + (k := k) (K := AlgebraicClosure k) (PhaseVar n))) = ∅ ↔ + orderCharacteristicSupport k I = ∅ := by + rw [algebraicClosure_zeroLocus_eq_empty_iff, + orderCharacteristicSupport_eq_empty_iff] + + +end + +end Stafford38.Characteristic.GeometricSupportDescent diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportScalarExtension.lean b/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportScalarExtension.lean new file mode 100644 index 0000000000..11e8ec9b10 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/GeometricSupportScalarExtension.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.FilteredScalarLifting +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Reduced order support after scalar extension + +The terminal Gabber consumer is formulated over a Laurent-series coefficient +field. This file identifies its geometric reduced support with the ordinary +reduced order support of the scalar-extended canonical Weyl quotient. Thus a +universal Gabber theorem can be run directly over the extension field; no +unrecorded transport of Poisson closure is needed. +-/ + +namespace Stafford38.Characteristic.GeometricSupportScalarExtension + +open Stafford38 +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Weyl.FilteredScalarLifting +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.Weyl.PresentedScalarExtension + +noncomputable section + +universe u v + +variable {k : Type u} {K : Type v} +variable [Field k] [Field K] [Algebra k K] + +/-- Radical commutes with extension up to taking the target radical. This +form needs no surjectivity of the coefficient map. -/ +theorem radical_map_radical_eq + {σ : Type*} (I : Ideal (MvPolynomial σ k)) : + ((I.radical.map + (scalarPolynomialMap (k := k) (K := K) σ)).radical) = + ((I.map + (scalarPolynomialMap (k := k) (K := K) σ)).radical) := by + apply le_antisymm + · calc + (I.radical.map + (scalarPolynomialMap (k := k) (K := K) σ)).radical ≤ + ((I.map + (scalarPolynomialMap (k := k) (K := K) σ)).radical).radical := + Ideal.radical_mono + (Ideal.map_radical_le + (f := scalarPolynomialMap (k := k) (K := K) σ) (I := I)) + _ = (I.map + (scalarPolynomialMap (k := k) (K := K) σ)).radical := + Ideal.radical_idem _ + · apply Ideal.radical_mono + exact Ideal.map_mono Ideal.le_radical + +/-- The geometric reduced extension of the ground canonical support is +literally the reduced order support of the scalar-extended canonical quotient. +This is the coefficient-field bridge required by the terminal Laurent Gabber +interface. -/ +theorem geometricReducedOrderSupportIdeal_eq_scalarExtension + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + geometricReducedOrderSupportIdeal (k := k) (K := K) + (canonicalRightIdeal (presentedCoordinate k n) d N) = + reducedOrderSupportIdeal K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension + (k := k) (K := K) (n + 1) d) N) := by + change + (((orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).radical.map + (scalarPolynomialMap + (k := k) (K := K) (PhaseVar (n + 1)))).radical) = + (orderInitialIdeal K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension + (k := k) (K := K) (n + 1) d) N)).radical + rw [← symbolScalarExtension_toRingHom (k := k) (K := K) (n + 1)] + have heq : + orderInitialIdeal K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension + (k := k) (K := K) (n + 1) d) N) = + (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (symbolScalarExtension + (k := k) (K := K) (n + 1)).toRingHom := by + apply le_antisymm + · exact target_orderInitialIdeal_le_map_source_orderInitialIdeal + (k := k) (K := K) n N d + · exact presentedWeylScalarExtension_map_orderInitialIdeal_le + (k := k) (K := K) n N d + rw [heq] + exact radical_map_radical_eq + (K := K) + (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + + +end + +end Stafford38.Characteristic.GeometricSupportScalarExtension diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/HomogeneousChart.lean b/LeanPool/Stafford38/Stafford38/Characteristic/HomogeneousChart.lean new file mode 100644 index 0000000000..7c3e53fefc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/HomogeneousChart.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LinearAction +import Mathlib.RingTheory.MvPolynomial.Homogeneous + +/-! +# Homogeneous symbols and prospective monic charts + +Over a characteristic-zero field, a nonzero homogeneous phase-space symbol +has a nonvanishing point over the original field. Linear substitution evaluates +the transformed symbol along a coordinate axis at the corresponding matrix +column. Axis restriction to one variable identifies this value with the exact +pure-power coefficient. The remaining chart-existence obligation is to place +the chosen nonzero vector into a prescribed column of a symplectic matrix. +-/ + +namespace Stafford38.CharacteristicHomogeneousChart + +open Stafford38.Characteristic +open Stafford38.CharacteristicLinearAction + +noncomputable section +universe u +variable (k : Type u) [Field k] + +theorem exists_eval_ne_zero_of_homogeneous [CharZero k] + {n N : ℕ} {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) : + ∃ v : PhaseVar n → k, MvPolynomial.eval v P ≠ 0 := by + by_contra h + push_neg at h + exact hne (hP.eq_zero_of_forall_eval_eq_zero h) + +theorem eval_symbolLinearAlgHom {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (v : PhaseVar n → k) (P : SymbolRing k n) : + MvPolynomial.eval v (symbolLinearAlgHom k M P) = + MvPolynomial.eval (fun i => ∑ j, M i j * v j) P := by + rw [symbolLinearAlgHom] + change MvPolynomial.aeval v + (MvPolynomial.aeval (symbolLinearCombination k M) P) = + MvPolynomial.aeval (fun i => ∑ j, M i j * v j) P + rw [MvPolynomial.comp_aeval_apply] + congr 2 + funext i + simp [symbolLinearCombination] + +theorem homogeneous_unit_eq_monomial {N : ℕ} + (P : MvPolynomial Unit k) (hP : P.IsHomogeneous N) : + P = MvPolynomial.monomial (Finsupp.single () N) + (MvPolynomial.coeff (Finsupp.single () N) P) := by + ext d + by_cases hd : d = Finsupp.single () N + · subst d + simp + · have hdegree : d.degree ≠ N := by + intro hdeg + apply hd + have hdform : d = Finsupp.single () (d ()) := by + apply Finsupp.ext + intro i + rcases i with ⟨⟩ + simp + rw [hdform, Finsupp.degree_single] at hdeg + rw [hdform, hdeg] + rw [hP.coeff_eq_zero hdegree] + rw [MvPolynomial.coeff_monomial, if_neg (Ne.symm hd)] + +def axisPoint {n : ℕ} (t : PhaseVar n) : PhaseVar n → k := + fun i => if i = t then 1 else 0 + +def axisPolynomial {n : ℕ} (t : PhaseVar n) : + SymbolRing k n →ₐ[k] MvPolynomial Unit k := + MvPolynomial.aeval (fun i => if i = t then MvPolynomial.X () else 0) + +theorem axisPolynomial_isHomogeneous {n N : ℕ} + (t : PhaseVar n) {P : SymbolRing k n} (hP : P.IsHomogeneous N) : + (axisPolynomial k t P).IsHomogeneous N := by + simpa [axisPolynomial, ← MvPolynomial.aeval_eq_bind₁] using hP.aeval (n := 1) + (fun i => if i = t then MvPolynomial.X () else 0) + (fun i => by + by_cases hi : i = t + · simp [hi, MvPolynomial.isHomogeneous_X] + · simp [hi, MvPolynomial.isHomogeneous_zero]) + +theorem eval_axis_eq_eval_axisPolynomial_one {n : ℕ} + (t : PhaseVar n) (P : SymbolRing k n) : + MvPolynomial.eval (axisPoint k t) P = + MvPolynomial.eval (fun _ : Unit => (1 : k)) (axisPolynomial k t P) := by + change MvPolynomial.aeval (axisPoint k t) P = + MvPolynomial.aeval (fun _ : Unit => (1 : k)) + (MvPolynomial.aeval + (fun i => if i = t then MvPolynomial.X () else 0) P) + rw [MvPolynomial.comp_aeval_apply] + congr 2 + funext i + by_cases hi : i = t + · simp [axisPoint, hi] + · simp [axisPoint, hi] + +theorem eval_axis_eq_pureCoefficient {n N : ℕ} + (t : PhaseVar n) {P : SymbolRing k n} (hP : P.IsHomogeneous N) : + MvPolynomial.eval (axisPoint k t) P = + MvPolynomial.coeff (Finsupp.single () N) (axisPolynomial k t P) := by + rw [eval_axis_eq_eval_axisPolynomial_one] + rw [homogeneous_unit_eq_monomial k (axisPolynomial k t P) + (axisPolynomial_isHomogeneous k t hP)] + simp [MvPolynomial.eval_monomial] + +theorem symbolLinearCombination_isHomogeneous {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + (symbolLinearCombination k M i).IsHomogeneous 1 := by + rw [symbolLinearCombination] + apply MvPolynomial.IsHomogeneous.sum Finset.univ _ 1 + intro j hj + simpa using (MvPolynomial.isHomogeneous_C (PhaseVar n) (M i j)).mul + (MvPolynomial.isHomogeneous_X (R := k) j) + +theorem symbolLinearAlgHom_isHomogeneous {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + {P : SymbolRing k n} (hP : P.IsHomogeneous N) : + (symbolLinearAlgHom k M P).IsHomogeneous N := by + simpa [symbolLinearAlgHom] using hP.aeval (n := 1) + (symbolLinearCombination k M) + (symbolLinearCombination_isHomogeneous k M) + +theorem eval_symbolLinearAlgHom_axis {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (t : PhaseVar n) (P : SymbolRing k n) : + MvPolynomial.eval (axisPoint k t) (symbolLinearAlgHom k M P) = + MvPolynomial.eval (fun i => M i t) P := by + rw [eval_symbolLinearAlgHom] + congr 2 + funext i + simp [axisPoint] + +theorem pureCoefficient_symbolLinearAlgHom {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (t : PhaseVar n) {P : SymbolRing k n} (hP : P.IsHomogeneous N) : + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t (symbolLinearAlgHom k M P)) = + MvPolynomial.eval (fun i => M i t) P := by + rw [← eval_axis_eq_pureCoefficient k t + (symbolLinearAlgHom_isHomogeneous k M hP)] + exact eval_symbolLinearAlgHom_axis k M t P + +/- Exact statement pins for original-field nonvanishing and column detection. -/ +example [CharZero k] {n N : ℕ} {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) : + ∃ v : PhaseVar n → k, MvPolynomial.eval v P ≠ 0 := + exists_eval_ne_zero_of_homogeneous k hP hne + +example {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (t : PhaseVar n) {P : SymbolRing k n} (hP : P.IsHomogeneous N) : + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t (symbolLinearAlgHom k M P)) = + MvPolynomial.eval (fun i => M i t) P := + pureCoefficient_symbolLinearAlgHom k M t hP + + +end +end Stafford38.CharacteristicHomogeneousChart diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/HyperplaneRestriction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/HyperplaneRestriction.lean new file mode 100644 index 0000000000..238ae71c81 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/HyperplaneRestriction.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.HyperplaneRestriction + +/-! +# Compatibility import for algebraic hyperplane restriction + +The generic determinant-trick and support-exclusion declarations now live in +`AlgebraicAnalysis.Module.HyperplaneRestriction`. Stafford-specific filtered +strictness and D-module comparison remain in this repository. +-/ diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdeal.lean b/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdeal.lean new file mode 100644 index 0000000000..62ae18c430 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdeal.lean @@ -0,0 +1,338 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.EulerRemainder +import Mathlib.RingTheory.Support + +/-! +# Bernstein initial ideals and characteristic support + +For a right ideal in the presented Weyl algebra, its Bernstein principal +components generate an ordinary ideal in the commutative symbol ring. This +file defines the resulting cyclic graded module and its support. The +construction is concrete: no abstract D-module or characteristic-variety +interface is assumed. +-/ + +namespace Stafford38.CharacteristicInitialIdeal + +open Stafford38.Characteristic +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylEulerResidue + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Principal components of Bernstein-filtered elements of a right ideal. -/ +def bernsteinInitialGeneratorSet {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Set (SymbolRing k n) := + {P | ∃ (N : ℕ) (z : PresentedWeyl k n), + z ∈ bernsteinPiece k n N ∧ z ∈ I ∧ + P = presentedPrincipalComponent k bernsteinWeight N z} + +/-- The commutative initial ideal of a right ideal for the Bernstein +filtration. -/ +def bernsteinInitialIdeal {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Ideal (SymbolRing k n) := + Ideal.span (bernsteinInitialGeneratorSet k I) + +/-- The cyclic commutative module defined by the Bernstein initial ideal. -/ +abbrev BernsteinCharacteristicModule {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) := + SymbolRing k n ⧸ bernsteinInitialIdeal k I + +private theorem quotient_subsingleton_iff_top {R : Type u} [CommRing R] + (J : Ideal R) : Subsingleton (R ⧸ J) ↔ J = ⊤ := by + constructor + · intro h + apply le_antisymm le_top + intro r hr + apply (Ideal.Quotient.eq_zero_iff_mem).mp + exact Subsingleton.elim (Ideal.Quotient.mk J r) 0 + · intro h + constructor + intro a b + obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective a + obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective b + have ha : Ideal.Quotient.mk J a = 0 := + (Ideal.Quotient.eq_zero_iff_mem).2 (h ▸ trivial) + have hb : Ideal.Quotient.mk J b = 0 := + (Ideal.Quotient.eq_zero_iff_mem).2 (h ▸ trivial) + exact ha.trans hb.symm + +/-- Characteristic support as module support on the affine symbol spectrum. -/ +def bernsteinCharacteristicSupport {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Set (PrimeSpectrum (SymbolRing k n)) := + Module.support (SymbolRing k n) (BernsteinCharacteristicModule k I) + +/-- The characteristic module is cyclic, so its support is exactly the closed +set cut out by the initial ideal. -/ +theorem bernsteinCharacteristicSupport_eq_zeroLocus {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : + bernsteinCharacteristicSupport k I = + PrimeSpectrum.zeroLocus (bernsteinInitialIdeal k I) := by + rw [bernsteinCharacteristicSupport, Module.support_of_algebra] + apply congrArg PrimeSpectrum.zeroLocus + ext P + change algebraMap (SymbolRing k n) (BernsteinCharacteristicModule k I) P = 0 ↔ + P ∈ bernsteinInitialIdeal k I + exact Ideal.Quotient.eq_zero_iff_mem + +/-- Empty characteristic support is equivalent to the initial ideal being +the unit ideal. Reflecting this condition back to the Weyl right ideal is a +separate filtered degree-lowering theorem. -/ +theorem bernsteinCharacteristicSupport_eq_empty_iff {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : + bernsteinCharacteristicSupport k I = ∅ ↔ + bernsteinInitialIdeal k I = ⊤ := by + rw [bernsteinCharacteristicSupport, Module.support_eq_empty_iff, + quotient_subsingleton_iff_top] + +theorem principalComponent_mem_bernsteinInitialIdeal {n N : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (z : PresentedWeyl k n) + (hz : z ∈ bernsteinPiece k n N) (hI : z ∈ I) : + presentedPrincipalComponent k bernsteinWeight N z ∈ + bernsteinInitialIdeal k I := by + apply Ideal.subset_span + exact ⟨N, z, hz, hI, rfl⟩ + +theorem mem_annihilator_bernsteinCharacteristicModule {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) {P : SymbolRing k n} + (hP : P ∈ bernsteinInitialIdeal k I) : + P ∈ Module.annihilator (SymbolRing k n) + (BernsteinCharacteristicModule k I) := by + rw [Module.mem_annihilator] + intro q + obtain ⟨r, rfl⟩ := Ideal.Quotient.mk_surjective q + change Ideal.Quotient.mk (bernsteinInitialIdeal k I) (P * r) = 0 + rw [Ideal.Quotient.eq_zero_iff_mem] + exact (bernsteinInitialIdeal k I).mul_mem_right r hP + +/-- Every element of the initial ideal vanishes on characteristic support. -/ +theorem bernsteinCharacteristicSupport_subset_zeroLocus {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) {P : SymbolRing k n} + (hP : P ∈ bernsteinInitialIdeal k I) : + bernsteinCharacteristicSupport k I ⊆ + PrimeSpectrum.zeroLocus ({P} : Set (SymbolRing k n)) := by + intro p hp + rw [PrimeSpectrum.mem_zeroLocus] + intro f hf + rw [Set.mem_singleton_iff.mp hf] + exact Module.annihilator_le_of_mem_support hp + (mem_annihilator_bernsteinCharacteristicModule k I hP) + +/-- The defining operator belongs to the literal canonical right ideal, so +its Bernstein principal component belongs to the corresponding initial +ideal. -/ +theorem canonical_principalComponent_mem_initialIdeal + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + presentedPrincipalComponent k bernsteinWeight N d ∈ + bernsteinInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N) := by + exact principalComponent_mem_bernsteinInitialIdeal k _ d hd.1 + (firstGenerator_mem (presentedCoordinate k n) d N) + +/-- The concrete characteristic support is contained in the normalized +principal-symbol hypersurface. -/ +theorem canonical_bernsteinCharacteristicSupport_subset_principal_zeroLocus + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + bernsteinCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊆ + PrimeSpectrum.zeroLocus + ({presentedPrincipalComponent k bernsteinWeight N d} : + Set (SymbolRing k (n + 1))) := by + exact bernsteinCharacteristicSupport_subset_zeroLocus k _ + (canonical_principalComponent_mem_initialIdeal k n N hd) + +theorem canonical_principalComponent_pureMomentumCoefficient + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + MvPolynomial.coeff + (Finsupp.single (.inr (0 : Fin (n + 1))) N) + (presentedPrincipalComponent k bernsteinWeight N d) = 1 := by + rw [coeff_principal_pure_eq_normalForm] + exact hd.2 + +/-! ## Differential-order characteristic support + +The preceding Bernstein construction is a finite-weight scaffold. The +noncharacteristic theorem uses the differential-order filtration, whose base +variables have weight zero and fibre variables weight one. The canonical +theorems below deliberately retain the normalized Bernstein bound: the +in characteristic zero, symplectic normalization produces it for every nonzero +non-scalar operator +(`Stafford38.WeylMonicNormalization.scalar_or_normalized_symplectic_image`), and together +with order degree `N` it forces the order principal symbol to involve fibre +variables only. This implication is proved explicitly below. + +The cyclic quotient by `orderInitialIdeal` is the intended concrete model for +the associated graded quotient. Its identification with the filtration +quotients, and reflection of an empty order support back to the Weyl quotient, +remain separate theorems; neither is assumed here. -/ + +def orderInitialGeneratorSet {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Set (SymbolRing k n) := + {P | ∃ (N : ℕ) (z : PresentedWeyl k n), + z ∈ orderPiece k n N ∧ z ∈ I ∧ + P = presentedPrincipalComponent k orderWeight N z} + +def orderInitialIdeal {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Ideal (SymbolRing k n) := + Ideal.span (orderInitialGeneratorSet k I) + +abbrev OrderCharacteristicModule {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) := + SymbolRing k n ⧸ orderInitialIdeal k I + +def orderCharacteristicSupport {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : Set (PrimeSpectrum (SymbolRing k n)) := + Module.support (SymbolRing k n) (OrderCharacteristicModule k I) + +theorem orderCharacteristicSupport_eq_zeroLocus {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : + orderCharacteristicSupport k I = + PrimeSpectrum.zeroLocus (orderInitialIdeal k I) := by + rw [orderCharacteristicSupport, Module.support_of_algebra] + apply congrArg PrimeSpectrum.zeroLocus + ext P + change algebraMap (SymbolRing k n) (OrderCharacteristicModule k I) P = 0 ↔ + P ∈ orderInitialIdeal k I + exact Ideal.Quotient.eq_zero_iff_mem + +theorem orderCharacteristicSupport_eq_empty_iff {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) : + orderCharacteristicSupport k I = ∅ ↔ orderInitialIdeal k I = ⊤ := by + rw [orderCharacteristicSupport, Module.support_eq_empty_iff, + quotient_subsingleton_iff_top] + +/-- Differential order is bounded above by Bernstein degree on every PBW +monomial. -/ +theorem monomialWeight_order_le_bernstein {n : ℕ} + (m : PhaseVar n →₀ ℕ) : + monomialWeight (@orderWeight n) m ≤ + monomialWeight (@bernsteinWeight n) m := by + classical + simp only [monomialWeight, Finsupp.weight_apply] + apply Finsupp.sum_le_sum + intro j hj + cases j <;> simp [orderWeight, fibreWeight, bernsteinWeight] + +/-- If order degree reaches a Bernstein bound, no coordinate exponent can +occur. -/ +theorem coordinateExponent_eq_zero_of_order_eq_of_bernstein_le + {n N : ℕ} (m : PhaseVar n →₀ ℕ) + (horder : monomialWeight (@orderWeight n) m = N) + (hbernstein : monomialWeight (@bernsteinWeight n) m ≤ N) + (i : Fin n) : m (.inl i) = 0 := by + by_contra hi + let m' := m - Finsupp.single (.inl i) 1 + have hordSub := Finsupp.weight_sub_single_add + (w := @orderWeight n) hi + have hbernSub := Finsupp.weight_sub_single_add + (w := @bernsteinWeight n) hi + have hle := monomialWeight_order_le_bernstein m' + have hordCoordinate : orderWeight (.inl i) = 0 := by + simp [orderWeight, fibreWeight] + have hbernCoordinate : bernsteinWeight (.inl i) = 1 := by + simp [bernsteinWeight] + change monomialWeight (@orderWeight n) m' + orderWeight (.inl i) = + monomialWeight (@orderWeight n) m at hordSub + change monomialWeight (@bernsteinWeight n) m' + bernsteinWeight (.inl i) = + monomialWeight (@bernsteinWeight n) m at hbernSub + rw [hordCoordinate, add_zero, horder] at hordSub + rw [hbernCoordinate] at hbernSub + omega + +/-- A symbol uses only fibre variables when every monomial carrying a +coordinate exponent has zero coefficient. -/ +def IsFibreOnly {n : ℕ} (P : SymbolRing k n) : Prop := + ∀ m, MvPolynomial.coeff m P ≠ 0 → + ∀ i : Fin n, m (.inl i) = 0 + +theorem orderPrincipalComponent_mem_initialIdeal {n N : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (z : PresentedWeyl k n) + (hz : z ∈ orderPiece k n N) (hI : z ∈ I) : + presentedPrincipalComponent k orderWeight N z ∈ orderInitialIdeal k I := by + apply Ideal.subset_span + exact ⟨N, z, hz, hI, rfl⟩ + +theorem orderCharacteristicSupport_subset_zeroLocus {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) {P : SymbolRing k n} + (hP : P ∈ orderInitialIdeal k I) : + orderCharacteristicSupport k I ⊆ + PrimeSpectrum.zeroLocus ({P} : Set (SymbolRing k n)) := by + rw [orderCharacteristicSupport_eq_zeroLocus] + intro p hp + rw [PrimeSpectrum.mem_zeroLocus] at hp ⊢ + intro f hf + rw [Set.mem_singleton_iff.mp hf] + exact hp hP + +theorem canonical_orderPrincipalComponent_mem_initialIdeal + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + presentedPrincipalComponent k orderWeight N d ∈ + orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N) := by + exact orderPrincipalComponent_mem_initialIdeal k _ d + (bernsteinPiece_le_orderPiece k (n + 1) N hd.1) + (firstGenerator_mem (presentedCoordinate k n) d N) + +theorem canonical_orderCharacteristicSupport_subset_principal_zeroLocus + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊆ + PrimeSpectrum.zeroLocus + ({presentedPrincipalComponent k orderWeight N d} : + Set (SymbolRing k (n + 1))) := by + exact orderCharacteristicSupport_subset_zeroLocus k _ + (canonical_orderPrincipalComponent_mem_initialIdeal k n N hd) + +theorem canonical_orderPrincipalComponent_pureMomentumCoefficient + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + MvPolynomial.coeff + (Finsupp.single (.inr (0 : Fin (n + 1))) N) + (presentedPrincipalComponent k orderWeight N d) = 1 := by + rw [coeff_presentedPrincipalComponent] + have hweight : monomialWeight (@orderWeight (n + 1)) + (Finsupp.single (.inr (0 : Fin (n + 1))) N) = N := by + simp [monomialWeight, orderWeight, fibreWeight] + rw [if_pos hweight] + exact hd.2 + +/-- The normalized Bernstein bound makes the degree-`N` order symbol a +constant-coefficient polynomial in the fibre variables. -/ +theorem canonical_orderPrincipalComponent_isFibreOnly + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + IsFibreOnly k (presentedPrincipalComponent k orderWeight N d) := by + intro m hm i + rw [coeff_presentedPrincipalComponent] at hm + by_cases horder : monomialWeight (@orderWeight (n + 1)) m = N + · rw [if_pos horder] at hm + have hbernstein := + (mem_presentedWeightPiece k (@bernsteinWeight (n + 1)) N d).mp + hd.1 m hm + exact coordinateExponent_eq_zero_of_order_eq_of_bernstein_le + m horder hbernstein i + · rw [if_neg horder] at hm + exact (hm rfl).elim + + +end + +end Stafford38.CharacteristicInitialIdeal diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdealHomogeneous.lean b/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdealHomogeneous.lean new file mode 100644 index 0000000000..1ec01331b6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/InitialIdealHomogeneous.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.FilteredQuotientGraded + +/-! +# Homogeneous pieces of the order initial ideal + +The generators of `orderInitialIdeal` are weighted homogeneous and are exact +symbol relations. This file proves that taking the degree-`N` homogeneous +component of any element of their ideal span again gives an exact degree-`N` +relation. The proof uses the finite direct-sum decomposition of each +polynomial multiplier and the homogeneous relation closure proved in +`FilteredQuotientGraded`. +-/ + +namespace Stafford38.CharacteristicInitialIdealHomogeneous + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicFilteredQuotientGraded +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylLeadingSymbol + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev OrderHomogeneous (N : ℕ) := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N + +private abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (n := n) k) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- Only finitely many order-homogeneous components of a symbol are nonzero. -/ +theorem orderHomogeneousComponent_support_finite (P : SymbolRing k n) : + (Function.support fun N => + MvPolynomial.weightedHomogeneousComponent (@orderWeight n) N P).Finite := + MvPolynomial.weightedHomogeneousComponent_finsupp P + +/-- Reconstruction from the finite family of order-homogeneous components. -/ +theorem finsum_orderHomogeneousComponent (P : SymbolRing k n) : + (∑ᶠ N, MvPolynomial.weightedHomogeneousComponent + (@orderWeight n) N P) = P := + MvPolynomial.sum_weightedHomogeneousComponent (@orderWeight n) P + +/-- Multiplying a symbol whose every homogeneous component is an exact +relation preserves that property. -/ +private theorem decompose_mul_mem_orderSymbolRelation + (I : RightIdeal (PresentedWeyl k n)) (a x : SymbolRing k n) + (hx : ∀ M, DirectSum.decompose (orderDecomposition (n := n) k) x M ∈ + orderSymbolRelation k I M) (N : ℕ) : + DirectSum.decompose (orderDecomposition (n := n) k) (a * x) N ∈ + orderSymbolRelation k I N := by + classical + letI : ∀ (M : ℕ) (Q : OrderHomogeneous (n := n) k M), + Decidable (Q ≠ 0) := + fun _ Q => Classical.propDecidable (Q ≠ 0) + have hxsum : + (∑ M ∈ (DirectSum.decompose + (orderDecomposition (n := n) k) x).support, + (DirectSum.decompose (orderDecomposition (n := n) k) x M : + SymbolRing k n)) = x := + DirectSum.sum_support_decompose (orderDecomposition (n := n) k) x + rw [← hxsum, Finset.mul_sum, + DirectSum.decompose_sum] + rw [DFinsupp.finset_sum_apply] + apply Submodule.sum_mem + intro M hM + by_cases hMN : M ≤ N + · have hmul := homogeneousRightMul_mem_orderSymbolRelation k I + (DirectSum.decompose (orderDecomposition k) a (N - M)) + (DirectSum.decompose (orderDecomposition (n := n) k) x M) (hx M) + have hsum : M + (N - M) = N := Nat.add_sub_of_le hMN + rw [← hsum] + have hMN' : M ≤ M + (N - M) := Nat.le_add_right M (N - M) + have heq : + DirectSum.decompose (orderDecomposition (n := n) k) + (a * (DirectSum.decompose (orderDecomposition (n := n) k) x M : + SymbolRing k n)) (M + (N - M)) = + homogeneousRightMul k + (DirectSum.decompose (orderDecomposition (n := n) k) a (N - M)) + (DirectSum.decompose (orderDecomposition (n := n) k) x M) := by + apply Subtype.ext + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition k) + (DirectSum.decompose (orderDecomposition (n := n) k) x M).property hMN'] + simp only [coe_homogeneousRightMul] + rw [Nat.add_sub_cancel_left] + exact mul_comm + (DirectSum.decompose (orderDecomposition (n := n) k) a (N - M) : + SymbolRing k n) + (DirectSum.decompose (orderDecomposition (n := n) k) x M : + SymbolRing k n) + rw [heq] + exact hmul + · have heq : + DirectSum.decompose (orderDecomposition (n := n) k) + (a * (DirectSum.decompose (orderDecomposition (n := n) k) x M : + SymbolRing k n)) N = 0 := by + apply Subtype.ext + exact DirectSum.coe_decompose_mul_of_right_mem_of_not_le + (orderDecomposition k) + (DirectSum.decompose (orderDecomposition (n := n) k) x M).property hMN + rw [heq] + exact Submodule.zero_mem _ + +/-- Every homogeneous component of the ideal generated by order-principal +symbols is an exact symbol relation in that degree. -/ +private theorem all_decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) + (hP : P ∈ orderInitialIdeal k I) : + ∀ N, DirectSum.decompose (orderDecomposition (n := n) k) P N ∈ + orderSymbolRelation k I N := by + classical + change P ∈ Ideal.span (orderInitialGeneratorSet k I) at hP + induction hP using Submodule.span_induction with + | mem P hP => + intro N + obtain ⟨M, z, hzM, hzI, rfl⟩ := hP + let Q : OrderHomogeneous k M := + principalComponentOnPiece k (@orderWeight n) M ⟨z, hzM⟩ + have hQ : Q ∈ orderSymbolRelation k I M := + principalComponent_mem_orderSymbolRelation k I M z hzM hzI + by_cases hNM : N = M + · subst N + change DirectSum.decompose (orderDecomposition (n := n) k) + (Q : SymbolRing k n) M ∈ orderSymbolRelation k I M + simpa only [DirectSum.decompose_coe, DirectSum.of_eq_same] using hQ + · have hzero : + (DirectSum.decompose (orderDecomposition k) + (presentedPrincipalComponent k orderWeight M z) N : + SymbolRing k n) = 0 := by + change DirectSum.decompose (orderDecomposition k) + (Q : SymbolRing k n) N = (0 : SymbolRing k n) + exact DirectSum.decompose_of_mem_ne (orderDecomposition k) Q.property + (fun h => hNM h.symm) + have hzero' : DirectSum.decompose (orderDecomposition k) + (presentedPrincipalComponent k orderWeight M z) N = 0 := + Subtype.ext hzero + rw [hzero'] + exact Submodule.zero_mem _ + | zero => + intro N + rw [DirectSum.decompose_zero] + exact Submodule.zero_mem _ + | add P Q _ _ hP hQ => + intro N + simpa only [DirectSum.decompose_add, DirectSum.add_apply] using + (Submodule.add_mem (orderSymbolRelation k I N) (hP N) (hQ N)) + | smul a P _ hP => + intro N + change DirectSum.decompose (orderDecomposition k) (a * P) N ∈ + orderSymbolRelation k I N + exact decompose_mul_mem_orderSymbolRelation k I a P hP N + +/-- Every homogeneous component of the ideal generated by order-principal +symbols is an exact symbol relation in that degree. -/ +theorem decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) + (hP : P ∈ orderInitialIdeal k I) (N : ℕ) : + DirectSum.decompose (orderDecomposition (n := n) k) P N ∈ + orderSymbolRelation k I N := + all_decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal k I P hP N + +/-- Reverse homogeneous-piece inclusion: a degree-`N` homogeneous element of +the order initial ideal is an exact relation in degree `N`. -/ +theorem mem_orderSymbolRelation_of_coe_mem_orderInitialIdeal + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (P : OrderHomogeneous k N) + (hP : (P : SymbolRing k n) ∈ orderInitialIdeal k I) : + P ∈ orderSymbolRelation k I N := by + have hcomponent := + decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal k I P hP N + simpa [DirectSum.decompose_coe] using hcomponent + +/-- Exact homogeneous relations are precisely the homogeneous pieces of the +order initial ideal. -/ +theorem mem_orderSymbolRelation_iff_coe_mem_orderInitialIdeal + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) + (P : OrderHomogeneous k N) : + P ∈ orderSymbolRelation k I N ↔ + (P : SymbolRing k n) ∈ orderInitialIdeal k I := + ⟨coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k I N P, + mem_orderSymbolRelation_of_coe_mem_orderInitialIdeal k I N P⟩ + + +end + +end Stafford38.CharacteristicInitialIdealHomogeneous diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LinearAction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LinearAction.lean new file mode 100644 index 0000000000..9adb3ae228 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LinearAction.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial + +/-! +# Linear substitutions on polynomial phase space + +A square matrix acts on the phase-space polynomial ring by substituting its +row-linear combination for each variable. Composition is contravariant in the +matrix order, matching the Weyl-generator substitution convention. Explicit +mutual inverse certificates produce an algebra equivalence. +-/ + +namespace Stafford38.CharacteristicLinearAction + +open Stafford38.Characteristic + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +def symbolLinearCombination {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + SymbolRing k n := + ∑ j, MvPolynomial.C (M i j) * MvPolynomial.X j + +def symbolLinearAlgHom {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) : + SymbolRing k n →ₐ[k] SymbolRing k n := + MvPolynomial.aeval (symbolLinearCombination k M) + +@[simp] theorem symbolLinearAlgHom_X {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + symbolLinearAlgHom k M (MvPolynomial.X i) = + symbolLinearCombination k M i := by + rw [symbolLinearAlgHom, MvPolynomial.aeval_X] + +@[simp] theorem symbolLinearAlgHom_C {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (c : k) : + symbolLinearAlgHom k M (MvPolynomial.C c) = MvPolynomial.C c := by + rw [symbolLinearAlgHom, MvPolynomial.aeval_C] + rfl + +theorem symbolLinearAlgHom_comp {n : ℕ} + (M N : Matrix (PhaseVar n) (PhaseVar n) k) : + (symbolLinearAlgHom k M).comp (symbolLinearAlgHom k N) = + symbolLinearAlgHom k (N * M) := by + apply MvPolynomial.algHom_ext + intro i + rw [AlgHom.comp_apply, symbolLinearAlgHom_X, symbolLinearAlgHom_X] + simp only [symbolLinearCombination, map_sum, map_mul, + symbolLinearAlgHom_C, symbolLinearAlgHom_X, Matrix.mul_apply] + simp only [Finset.mul_sum, Finset.sum_mul, mul_assoc] + rw [Finset.sum_comm] + +theorem symbolLinearAlgHom_one {n : ℕ} : + symbolLinearAlgHom k (1 : Matrix (PhaseVar n) (PhaseVar n) k) = + AlgHom.id k (SymbolRing k n) := by + apply MvPolynomial.algHom_ext + intro i + simp [symbolLinearCombination, Matrix.one_apply] + +/-- The polynomial substitution equivalence attached to explicitly certified +inverse matrices. -/ +def symbolLinearAlgEquivOfInverse {n : ℕ} + (M N : Matrix (PhaseVar n) (PhaseVar n) k) + (hMN : M * N = 1) (hNM : N * M = 1) : + SymbolRing k n ≃ₐ[k] SymbolRing k n := + AlgEquiv.ofAlgHom (symbolLinearAlgHom k M) (symbolLinearAlgHom k N) + (by rw [symbolLinearAlgHom_comp, hNM, symbolLinearAlgHom_one]) + (by rw [symbolLinearAlgHom_comp, hMN, symbolLinearAlgHom_one]) + +@[simp] theorem symbolLinearAlgEquivOfInverse_X {n : ℕ} + (M N : Matrix (PhaseVar n) (PhaseVar n) k) + (hMN : M * N = 1) (hNM : N * M = 1) (i : PhaseVar n) : + symbolLinearAlgEquivOfInverse k M N hMN hNM (MvPolynomial.X i) = + symbolLinearCombination k M i := + symbolLinearAlgHom_X k M i + +@[simp] theorem symbolLinearAlgEquivOfInverse_symm_X {n : ℕ} + (M N : Matrix (PhaseVar n) (PhaseVar n) k) + (hMN : M * N = 1) (hNM : N * M = 1) (i : PhaseVar n) : + (symbolLinearAlgEquivOfInverse k M N hMN hNM).symm + (MvPolynomial.X i) = symbolLinearCombination k N i := + symbolLinearAlgHom_X k N i + +/- Exact statement pins for matrix order and both substitutions. -/ +example {n : ℕ} (M N : Matrix (PhaseVar n) (PhaseVar n) k) : + (symbolLinearAlgHom k M).comp (symbolLinearAlgHom k N) = + symbolLinearAlgHom k (N * M) := + symbolLinearAlgHom_comp k M N + +example {n : ℕ} (M N : Matrix (PhaseVar n) (PhaseVar n) k) + (hMN : M * N = 1) (hNM : N * M = 1) (i : PhaseVar n) : + (symbolLinearAlgEquivOfInverse k M N hMN hNM).symm + (MvPolynomial.X i) = symbolLinearCombination k N i := + symbolLinearAlgEquivOfInverse_symm_X k M N hMN hNM i + + +end + +end Stafford38.CharacteristicLinearAction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedHighPowerTwoBlockVanishing.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedHighPowerTwoBlockVanishing.lean new file mode 100644 index 0000000000..6ef329f0c9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedHighPowerTwoBlockVanishing.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedSpecializationActionCompatibility +import LeanPool.Stafford38.Stafford38.Characteristic.RightReesArtinianAdapter + +/-! +# Localized high-power two-block vanishing + +This file discharges the elementwise two-block condition in the concrete +right-Rees Artinian adapter. A localized scalar whose specialization lies in +an annihilating ideal sends every deformation vector into the parameter +image. Two such scalar actions therefore produce two parameter factors and +vanish by square-zero. + +The opposite localization acts on the left in the order corresponding to +written right multiplication. The finite sum below consequently retains the +displayed product order. No residue-field action is placed on the deformation +module. +-/ + +namespace Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing + +open Stafford38.Characteristic.LocalizedSpecializationActionCompatibility +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] + +/-- The central deformation parameter remains central after Ore localization. +The multiplication is in the opposite ring, hence represents written right +multiplication in the original deformation ring. -/ +theorem localizedParameter_comm + (a : OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) : + OreLocalization.numeratorRingHom (MulOpposite.op D.c) * a = + a * OreLocalization.numeratorRingHom (MulOpposite.op D.c) := by + induction a using OreLocalization.ind with + | _ b s => + rw [OreLocalization.numeratorRingHom_apply] + rw [OreLocalization.oreDiv_mul_char + (MulOpposite.op D.c) b 1 s (MulOpposite.op D.c) s] + · rw [OreLocalization.mul_div_one] + congr 1 + · apply MulOpposite.unop_injective + exact (D.c_center.comm b.unop).symm + · simp + · apply MulOpposite.unop_injective + exact D.c_center.comm s.val.unop + +/-- A localized scalar action commutes with the concrete parameter action. +This is the bridge that permits the two high-power blocks to contribute two +successive parameter factors. -/ +theorem smul_localizedCAct + (a : OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) + (z : LocalizedDeformationModule D S) : + a • localizedCAct D S z = localizedCAct D S (a • z) := by + rw [localizedCAct_apply, localizedCAct_apply] + rw [← OreLocalization.oreDiv_one_smul] + rw [← mul_smul] + rw [← OreLocalization.numeratorRingHom_apply (MulOpposite.op D.c)] + rw [← localizedParameter_comm D S a, mul_smul] + exact OreLocalization.oreDiv_one_smul _ _ + +/-- If the specialization of a localized scalar lies in an ideal annihilating +the special fibre, then its action on every deformation vector is a localized +parameter multiple. -/ +theorem smul_mem_parameterRange_of_specialization_mem_annihilator + (a : OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) + (ha : localizedOppositeSpecialization D S a ∈ + Module.annihilator (Localization S) (LocalizedModule S G)) + (z : LocalizedDeformationModule D S) : + a • z ∈ AddMonoidHom.range (localizedCAct D S) := by + rw [← localizedSpecialization_ker_eq_range D S] + rw [AddMonoidHom.mem_ker, localizedSpecialization_smul D S] + exact Module.mem_annihilator.mp ha (localizedSpecialization D S z) + +/-- Two localized factors whose specializations lie in one annihilating ideal +act successively by zero. -/ +theorem product_smul_eq_zero_of_specializations_mem_annihilator + (a b : OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) + (ha : localizedOppositeSpecialization D S a ∈ + Module.annihilator (Localization S) (LocalizedModule S G)) + (hb : localizedOppositeSpecialization D S b ∈ + Module.annihilator (Localization S) (LocalizedModule S G)) + (z : LocalizedDeformationModule D S) : + (a * b) • z = 0 := by + obtain ⟨w, hw⟩ := + smul_mem_parameterRange_of_specialization_mem_annihilator D S b hb z + obtain ⟨v, hv⟩ := + smul_mem_parameterRange_of_specialization_mem_annihilator D S a ha w + rw [mul_smul, ← hw, smul_localizedCAct D S, ← hv] + exact localizedCAct_sq_eq_zero D S v + +/-- An annihilating maximal-ideal power supplies the exact two-block +vanishing proposition required by `RightReesArtinianAdapter`. -/ +theorem localizedHighPowerTwoBlockVanishing_of_annihilatingPower + [IsLocalRing (Localization S)] + (q : ℕ) + (hpow : IsLocalRing.maximalIdeal (Localization S) ^ q ≤ + Module.annihilator (Localization S) (LocalizedModule S G)) : + LocalizedHighPowerTwoBlockVanishing D S q := by + intro iota s a b ha hb z + rw [Finset.sum_smul] + apply Finset.sum_eq_zero + intro i hi + exact product_smul_eq_zero_of_specializations_mem_annihilator D S + (a i) (b i) (hpow (ha i hi)) (hpow (hb i hi)) z + + +end + +end Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedKernelCokernelEquivalences.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedKernelCokernelEquivalences.lean new file mode 100644 index 0000000000..9f5f1d9ed8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedKernelCokernelEquivalences.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedKernelCokernelEquivalences + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.LocalizedKernelCokernelEquivalences + +export AlgebraicAnalysis.LocalizedKernelCokernelEquivalences (localizedMap localizedMap_apply localizedEquiv localizedKernelEquiv localizedCokernelEquiv) + +end Stafford38.Characteristic.LocalizedKernelCokernelEquivalences diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedMinimalSupportAvoidance.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedMinimalSupportAvoidance.lean new file mode 100644 index 0000000000..178c08e928 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedMinimalSupportAvoidance.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.LocalizedMinimalSupportAvoidance + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.LocalizedMinimalSupportAvoidance + +export AlgebraicAnalysis.LocalizedMinimalSupportAvoidance (annihilator_localizedModule localized_minimalPrime_avoids) + +end Stafford38.Characteristic.LocalizedMinimalSupportAvoidance diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedOrderReesTwoJetSpecializationKernel.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedOrderReesTwoJetSpecializationKernel.lean new file mode 100644 index 0000000000..9239483b5a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedOrderReesTwoJetSpecializationKernel.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJetSpecializationKernel +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedRing + +/-! +# The localized order-Rees two-jet specialization kernel + +For the concrete order-Rees two-jet, localization of the opposite ring does +not enlarge the specialization kernel beyond the localized central parameter. +The proof is direct on Ore fractions. A denominator that kills the +specialized numerator is lifted through the surjective two-jet +specialization, the numerator is enlarged in the opposite ring, and the exact +unlocalized kernel theorem factors it by the Rees parameter. + +Products remain in the opposite/right-module orientation throughout. In +particular, the localized parameter is written on the left; centrality is used +explicitly before applying the unlocalized factorization. +-/ + +namespace Stafford38.CharacteristicLocalizedOrderReesTwoJetSpecializationKernel + +open Stafford38.Characteristic +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.CharacteristicOrderReesTwoJetSpecializationKernel +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev concreteData + (I : RightIdeal (PresentedWeyl k n)) := + filteredQuotientTwoJetTraceData k I + +variable (I : RightIdeal (PresentedWeyl k n)) +variable (S : Submonoid (SymbolRing k n)) +variable [OreLocalization.OreSet + (OppositeDenominators (concreteData k I) S)] + +/-- Written-order left multiplication by the localized central Rees +parameter. -/ +def localizedOrderReesTwoJetParameterMul : + OreLocalization (OppositeDenominators (concreteData k I) S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ) →+ + OreLocalization (OppositeDenominators (concreteData k I) S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ) where + toFun y := OreLocalization.numeratorHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) * y + map_zero' := mul_zero _ + map_add' := mul_add _ + +@[simp] theorem localizedOrderReesTwoJetParameterMul_apply + (y : OreLocalization (OppositeDenominators (concreteData k I) S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ)) : + localizedOrderReesTwoJetParameterMul k I S y = + OreLocalization.numeratorHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) * y := + rfl + +private theorem localized_parameter_mul_oreDiv + (b : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ) + (s : OppositeDenominators (concreteData k I) S) : + OreLocalization.numeratorHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) * + (b /ₒ s) = + (MulOpposite.op (orderReesTwoJetParameter (n := n) k) * b) /ₒ s := by + change + (MulOpposite.op (orderReesTwoJetParameter (n := n) k) /ₒ + (1 : OppositeDenominators (concreteData k I) S)) * + (b /ₒ s) = _ + simpa using OreLocalization.oreDiv_mul_char + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) b + (1 : OppositeDenominators (concreteData k I) S) s + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) s + (show (s : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ) * + MulOpposite.op (orderReesTwoJetParameter (n := n) k) = + MulOpposite.op (orderReesTwoJetParameter (n := n) k) * s from by + apply MulOpposite.unop_injective + exact (orderReesTwoJetParameter_mem_center (n := n) k).comm s.val.unop) + +/-- The concrete localized opposite order-Rees two-jet specialization has +exactly the left-principal kernel generated by the localized central +parameter, stated elementwise in written multiplication order. -/ +theorem localizedOrderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + (x : OreLocalization (OppositeDenominators (concreteData k I) S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ)) : + localizedOppositeSpecialization (concreteData k I) S x = 0 ↔ + ∃ y : OreLocalization (OppositeDenominators (concreteData k I) S) + ((OrderReesTwoJet (n := n) k)ᵐᵒᵖ), + OreLocalization.numeratorHom + (MulOpposite.op (orderReesTwoJetParameter (n := n) k)) * y = x := by + constructor + · intro hx + induction x using OreLocalization.ind with + | _ b s => + rw [localizedOppositeSpecialization_oreDiv] at hx + have hbase : + algebraMap (SymbolRing k n) (Localization S) + (orderReesTwoJetSpecialization (n := n) k b.unop) = 0 := by + exact (Units.isUnit + ((localizedDenominatorUnits (concreteData k I) S s)⁻¹)).mul_left_cancel + (by rw [mul_zero]; exact hx) + obtain ⟨u, hu⟩ := + (IsLocalization.map_eq_zero_iff S (Localization S) + (orderReesTwoJetSpecialization (n := n) k b.unop)).mp hbase + obtain ⟨a, ha⟩ := + orderReesTwoJetSpecialization_surjective (n := n) k (u : SymbolRing k n) + let v : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ := MulOpposite.op a + have hvS : v ∈ OppositeDenominators (concreteData k I) S := by + change orderReesTwoJetSpecialization (n := n) k a ∈ S + rw [ha] + exact u.property + have hvb_zero : + orderReesTwoJetSpecialization (n := n) k (v * b).unop = 0 := by + change orderReesTwoJetSpecialization (n := n) k (b.unop * a) = 0 + rw [map_mul, ha] + simpa [mul_comm] using hu + obtain ⟨q, hq⟩ := + (orderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + (n := n) k (v * b).unop).mp hvb_zero + have hfactor : + MulOpposite.op (orderReesTwoJetParameter (n := n) k) * + MulOpposite.op q = v * b := by + apply MulOpposite.unop_injective + change q * orderReesTwoJetParameter (n := n) k = b.unop * a + rw [← (orderReesTwoJetParameter_mem_center (n := n) k).comm q] + exact hq + have hvs : v * (s : (OrderReesTwoJet (n := n) k)ᵐᵒᵖ) ∈ + OppositeDenominators (concreteData k I) S := + mul_mem hvS s.property + let t : OppositeDenominators (concreteData k I) S := + ⟨v * s, hvs⟩ + refine ⟨(MulOpposite.op q) /ₒ t, ?_⟩ + rw [localized_parameter_mul_oreDiv] + rw [hfactor] + symm + exact OreLocalization.expand b s v hvs + · rintro ⟨y, rfl⟩ + rw [map_mul] + change + localizedOppositeSpecialization (concreteData k I) S + (OreLocalization.numeratorHom + (MulOpposite.op (concreteData k I).c)) * + localizedOppositeSpecialization (concreteData k I) S y = 0 + rw [localizedOppositeSpecialization_parameter, zero_mul] + +/-- Kernel/range form of the concrete localized principal-kernel theorem. -/ +theorem localizedOrderReesTwoJetSpecialization_ker_eq_range_parameterMul : + AddMonoidHom.ker + (localizedOppositeSpecialization (concreteData k I) S).toAddMonoidHom = + AddMonoidHom.range (localizedOrderReesTwoJetParameterMul k I S) := by + ext x + rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_range] + exact + localizedOrderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + k I S x + + +end + +end Stafford38.CharacteristicLocalizedOrderReesTwoJetSpecializationKernel diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedSpecializationActionCompatibility.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedSpecializationActionCompatibility.lean new file mode 100644 index 0000000000..b6b98ad2bb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedSpecializationActionCompatibility.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedRing + +/-! +# Localized specialization respects the localized action + +The Ore localization of the opposite deformation ring acts on the localized +deformation module. This file proves directly on displayed left-Ore +fractions that module specialization intertwines this action with the +commutative special-fibre localization action. + +The use of the opposite ring is load-bearing: an Ore equation in `Bᵐᵒᵖ` is +sent through `oppositeSpecializationRingHom`, whose multiplicativity is +exactly the reversal from written right multiplication to the left action. +No Artinian descent, characteristic-variety, or involutivity statement is +made here. +-/ + +namespace Stafford38.Characteristic.LocalizedSpecializationActionCompatibility + +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] + +/-- Specialization of the concrete localized deformation module intertwines +the full localized opposite-ring action with specialization of the scalar. +The multiplication displayed on the source is the left action corresponding +to written right multiplication before passage to the opposite ring. -/ +theorem localizedSpecialization_smul + (a : OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) + (z : LocalizedDeformationModule D S) : + localizedSpecialization D S (a • z) = + localizedOppositeSpecialization D S a • + localizedSpecialization D S z := by + induction a using OreLocalization.ind with + | _ b s => + induction z using OreLocalization.ind with + | _ m t => + obtain ⟨r, u, hur, haction⟩ := + OreLocalization.oreDivSMulChar' b m s t + rw [haction, localizedSpecialization_apply, + localizedSpecializationFun_oreDiv, + localizedOppositeSpecialization_oreDiv, + localizedSpecialization_apply, + localizedSpecializationFun_oreDiv] + have hscalar : + ((localizedDenominatorUnits D S s)⁻¹ : + Units (Localization S)) * + algebraMap R (Localization S) (D.pi b.unop) = + Localization.mk (D.pi b.unop) (denominatorMap D S s) := by + change + ((1 : R) /ₒ denominatorMap D S s) * + (D.pi b.unop /ₒ (1 : S)) = + D.pi b.unop /ₒ denominatorMap D S s + simpa only [one_mul] using + (OreLocalization.one_div_mul + (S := S) (r := D.pi b.unop) (s := (1 : S)) + (t := denominatorMap D S s)) + rw [hscalar, LocalizedModule.mk_smul_mk] + have hore := congrArg (oppositeSpecializationRingHom D) hur + simp only [map_mul, oppositeSpecializationRingHom_apply] at hore + apply LocalizedModule.mk_eq.mpr + refine ⟨1, ?_⟩ + simp only [one_smul, Submonoid.smul_def, Submonoid.coe_mul] + have hrho : D.rho (r • m) = D.pi r.unop • D.rho m := by + simpa using D.rho_action r.unop m + have hcoeff : + (D.pi s.val.unop * D.pi t.val.unop) * D.pi r.unop = + (D.pi u.val.unop * D.pi s.val.unop) * D.pi b.unop := by + calc + (D.pi s.val.unop * D.pi t.val.unop) * D.pi r.unop = + D.pi s.val.unop * (D.pi r.unop * D.pi t.val.unop) := by + ring + _ = D.pi s.val.unop * (D.pi u.val.unop * D.pi b.unop) := by + rw [hore] + _ = (D.pi u.val.unop * D.pi s.val.unop) * D.pi b.unop := by + ring + rw [hrho, ← mul_smul, ← mul_smul] + have hcoeff' : + ((denominatorMap D S s : R) * + (denominatorMap D S t : R)) * D.pi r.unop = + (denominatorMap D S (u * s) : R) * D.pi b.unop := by + rw [map_mul] + exact hcoeff + exact congrArg (fun q : R => q • D.rho m) hcoeff' + + +end + +end Stafford38.Characteristic.LocalizedSpecializationActionCompatibility diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockModuleExactness.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockModuleExactness.lean new file mode 100644 index 0000000000..b7eef32f09 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockModuleExactness.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockQuotient + +/-! +# Module exactness after the localized two-block ring quotient + +The two-block ideal annihilates the localized deformation module, so passage +to the quotient changes only its scalar ring. This file names the action of +the quotient parameter and identifies it exactly with the already constructed +localized parameter action. Parameter exactness and the additive +special-fibre equivalence therefore transfer without quotienting the module. + +No identification of the quotient ring modulo its parameter with the +commutative doubled-power quotient is asserted. +-/ + +namespace Stafford38.Characteristic.LocalizedTwoBlockModuleExactness + +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_R u_k u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] +variable [IsLocalRing (Localization S)] + +local notation "Wₗ" => LocalizedDeformationModule D S +local notation "A₀" => Localization S +local notation "𝔪" => IsLocalRing.maximalIdeal A₀ + +/-- The additive endomorphism induced by the parameter class in the localized +two-block quotient ring. -/ +def localizedTwoBlockParameterAct + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + Wₗ →+ Wₗ where + toFun w := + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) w + map_zero' := by + calc + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) 0 = + localizedCAct D S 0 := + localizedTwoBlock_parameter_smul D S q hpow 0 + _ = 0 := (localizedCAct D S).map_zero + map_add' x y := by + calc + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) (x + y) = + localizedCAct D S (x + y) := + localizedTwoBlock_parameter_smul D S q hpow (x + y) + _ = localizedCAct D S x + localizedCAct D S y := + (localizedCAct D S).map_add x y + _ = localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) x + + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) y := by + rw [localizedTwoBlock_parameter_smul, + localizedTwoBlock_parameter_smul] + +/-- Quotienting the scalar ring does not change the parameter endomorphism of +the localized deformation module. -/ +theorem localizedTwoBlockParameterAct_eq_localizedCAct + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + localizedTwoBlockParameterAct D S q hpow = + localizedCAct D S := by + ext w + exact localizedTwoBlock_parameter_smul D S q hpow w + +/-- The square-zero parameter sequence remains exact after descent of the +scalar action to the localized two-block quotient ring. -/ +theorem localizedTwoBlockParameterAct_ker_eq_range + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + AddMonoidHom.ker (localizedTwoBlockParameterAct D S q hpow) = + AddMonoidHom.range (localizedTwoBlockParameterAct D S q hpow) := by + rw [localizedTwoBlockParameterAct_eq_localizedCAct] + exact localizedCAct_ker_eq_range D S + +/-- The additive special fibre of the unchanged quotient-ring module is the +ordinary localized special fibre. -/ +noncomputable def localizedTwoBlockSpecialFibreAddEquiv + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + (Wₗ ⧸ AddMonoidHom.range + (localizedTwoBlockParameterAct D S q hpow)) ≃+ + LocalizedModule S G := by + rw [localizedTwoBlockParameterAct_eq_localizedCAct] + exact localizedSpecialFibreAddEquiv D S + + +end + +end Stafford38.Characteristic.LocalizedTwoBlockModuleExactness diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockPrincipalKernelDescent.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockPrincipalKernelDescent.lean new file mode 100644 index 0000000000..4d8d0a9c34 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockPrincipalKernelDescent.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedTwoBlockQuotient + +/-! +# Principal specialization kernels after the localized two-block quotient + +Suppose that the kernel of the localized opposite specialization is exactly +the left principal ideal generated by the localized square-zero parameter. +The kernel of the descended two-block specialization is then exactly the +left principal ideal generated by the parameter class in the quotient. + +The proof retains multiplication order. An element of the doubled power is +lifted as an ordered sum of products `a * b`; those products lie in the +two-block ideal. Only the remaining element of the original specialization +kernel is factored by the parameter. + +No Artinianness, module-action statement, adapted basis, or matrix identity is +used here. +-/ + +namespace Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent + +open Stafford38.Characteristic.LocalizedTwoBlockQuotient +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_R u_k u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] +variable [IsLocalRing (Localization S)] + +local notation "Cₗ" => + OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ) +local notation "A₀" => Localization S +local notation "𝔪" => IsLocalRing.maximalIdeal A₀ + +/-- Every element of the doubled power has an ordered lift in the two-block +ideal. Surjectivity is applied separately to the left and right factors, so +no commutation in the noncommutative source is used. -/ +theorem exists_mem_localizedTwoBlockIdeal_map_eq_of_mem_doubledPower + (q : ℕ) {r : A₀} + (hr : r ∈ localizedDoubledPower S q) : + ∃ z : Cₗ, + z ∈ localizedTwoBlockIdeal D S q ∧ + localizedOppositeSpecialization D S z = r := by + change r ∈ (𝔪 ^ q) • (𝔪 ^ q) at hr + refine Submodule.smul_induction_on hr ?_ ?_ + · intro a ha b hb + obtain ⟨x, hx⟩ := + localizedOppositeSpecialization_surjective D S a + obtain ⟨y, hy⟩ := + localizedOppositeSpecialization_surjective D S b + refine ⟨x * y, ?_, ?_⟩ + · apply TwoSidedIdeal.subset_span + exact ⟨x, + (mem_localizedHighPowerPullback_iff D S q x).2 (hx ▸ ha), + y, (mem_localizedHighPowerPullback_iff D S q y).2 (hy ▸ hb), rfl⟩ + · rw [map_mul, hx, hy] + rfl + · rintro r₁ r₂ ⟨z₁, hz₁, hmap₁⟩ ⟨z₂, hz₂, hmap₂⟩ + refine ⟨z₁ + z₂, + (localizedTwoBlockIdeal D S q).add_mem hz₁ hz₂, ?_⟩ + rw [map_add, hmap₁, hmap₂] + +/-- Written-order left multiplication by the parameter class in the +localized two-block quotient. -/ +def localizedTwoBlockParameterMul (q : ℕ) : + LocalizedTwoBlockRing D S q →+ + LocalizedTwoBlockRing D S q where + toFun y := + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) * y + map_zero' := mul_zero _ + map_add' := mul_add _ + +@[simp] +theorem localizedTwoBlockParameterMul_apply + (q : ℕ) (y : LocalizedTwoBlockRing D S q) : + localizedTwoBlockParameterMul D S q y = + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) * y := + rfl + +/-- Descent of an exact left-principal specialization kernel through the +two-block quotient. The principal-kernel hypothesis is stated on `Cₗ` in +the same written multiplication order as the conclusion. -/ +theorem localizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + (q : ℕ) + (hprincipal : ∀ x : Cₗ, + localizedOppositeSpecialization D S x = 0 ↔ + ∃ y : Cₗ, + OreLocalization.numeratorRingHom (MulOpposite.op D.c) * y = x) + (z : LocalizedTwoBlockRing D S q) : + localizedTwoBlockSpecialization D S q z = 0 ↔ + ∃ y : LocalizedTwoBlockRing D S q, + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) * y = z := by + induction z using Quotient.inductionOn' with + | _ x => + constructor + · intro hx + change Ideal.Quotient.mk (localizedDoubledPower S q) + (localizedOppositeSpecialization D S x) = 0 at hx + rw [Ideal.Quotient.eq_zero_iff_mem] at hx + obtain ⟨j, hj, hmapj⟩ := + exists_mem_localizedTwoBlockIdeal_map_eq_of_mem_doubledPower + D S q hx + have hzero : + localizedOppositeSpecialization D S (x - j) = 0 := by + rw [map_sub, hmapj, sub_self] + obtain ⟨y, hy⟩ := (hprincipal (x - j)).mp hzero + refine ⟨(localizedTwoBlockIdeal D S q).ringCon.mk' y, ?_⟩ + have hj0 : + (localizedTwoBlockIdeal D S q).ringCon.mk' j = 0 := by + apply (TwoSidedIdeal.mem_ker + ((localizedTwoBlockIdeal D S q).ringCon.mk')).1 + simpa using hj + calc + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) * + (localizedTwoBlockIdeal D S q).ringCon.mk' y = + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c) * y) := by + exact ((localizedTwoBlockIdeal D S q).ringCon.mk').map_mul _ _ |>.symm + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' (x - j) := + congrArg ((localizedTwoBlockIdeal D S q).ringCon.mk') hy + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' x - + (localizedTwoBlockIdeal D S q).ringCon.mk' j := + ((localizedTwoBlockIdeal D S q).ringCon.mk').map_sub x j + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' x := by + rw [hj0, sub_zero] + · rintro ⟨y, hy⟩ + rw [← hy, map_mul] + have hc0 : + localizedOppositeSpecialization D S + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) = 0 := + (hprincipal + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))).2 + ⟨1, mul_one _⟩ + rw [localizedTwoBlockSpecialization_mk, hc0, map_zero, zero_mul] + +/-- Kernel/range form of the descended left-principal kernel theorem. -/ +theorem localizedTwoBlockSpecialization_ker_eq_range_parameterMul + (q : ℕ) + (hprincipal : ∀ x : Cₗ, + localizedOppositeSpecialization D S x = 0 ↔ + ∃ y : Cₗ, + OreLocalization.numeratorRingHom (MulOpposite.op D.c) * y = x) : + AddMonoidHom.ker + (localizedTwoBlockSpecialization D S q).toAddMonoidHom = + AddMonoidHom.range (localizedTwoBlockParameterMul D S q) := by + ext z + rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_range] + exact localizedTwoBlockSpecialization_eq_zero_iff_exists_parameter_mul + D S q hprincipal z + + +end + +end Stafford38.Characteristic.LocalizedTwoBlockPrincipalKernelDescent diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockQuotient.lean b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockQuotient.lean new file mode 100644 index 0000000000..4855645e9a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/LocalizedTwoBlockQuotient.lean @@ -0,0 +1,347 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing +import Mathlib.Algebra.Module.RingHom +import Mathlib.RingTheory.Ideal.Quotient.Basic +import Mathlib.RingTheory.TwoSidedIdeal.Kernel +import Mathlib.RingTheory.TwoSidedIdeal.Operations + +/-! +# The localized two-block quotient + +The localized opposite deformation ring is noncommutative, so the candidate +truncation must be formed with a two-sided ideal rather than `Ideal.Quotient`. +For an annihilating power in the commutative special fibre, this file pulls +the power back to a two-sided ideal `H`, lets `J` be the two-sided span of the +products `a * b` with `a,b in H`, and proves that `J` annihilates the actual +localized deformation module. Consequently the action descends to the ring +congruence quotient by `J`. + +No source matrices, adapted basis, or trace identity is assumed here. +-/ + +namespace Stafford38.Characteristic.LocalizedTwoBlockQuotient + +open Stafford38.Characteristic.LocalizedHighPowerTwoBlockVanishing +open Stafford38.Characteristic.RightReesArtinianAdapter +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_C u_W u_R u_k u_B u_N u_G + +section AbstractQuotientAction + +variable {C : Type u_C} {W : Type u_W} +variable [Ring C] [AddCommGroup W] [Module C W] + +/-- The two-sided ideal of scalars acting by zero on every module vector. -/ +def actionAnnihilator : TwoSidedIdeal C := + TwoSidedIdeal.mk' + {a : C | ∀ w : W, a • w = 0} + (by intro w; exact zero_smul C w) + (by + intro a b ha hb w + rw [add_smul, ha w, hb w, add_zero]) + (by + intro a ha w + rw [neg_smul, ha w, neg_zero]) + (by + intro a b hb w + rw [mul_smul, hb w, smul_zero]) + (by + intro a b ha w + rw [mul_smul, ha (b • w)]) + +@[simp] +theorem mem_actionAnnihilator_iff {a : C} : + a ∈ actionAnnihilator (C := C) (W := W) ↔ ∀ w : W, a • w = 0 := by + simp [actionAnnihilator, TwoSidedIdeal.mem_mk'] + +/-- The two-sided ideal generated by products of two elements of `H`. -/ +def twoBlockIdeal (H : TwoSidedIdeal C) : TwoSidedIdeal C := + TwoSidedIdeal.span + {z : C | ∃ a ∈ H, ∃ b ∈ H, a * b = z} + +/-- Killing every displayed two-block product kills its full two-sided span. -/ +theorem twoBlockIdeal_le_actionAnnihilator + (H : TwoSidedIdeal C) + (hprod : ∀ a ∈ H, ∀ b ∈ H, ∀ w : W, (a * b) • w = 0) : + twoBlockIdeal H ≤ actionAnnihilator (C := C) (W := W) := by + intro z hz + change z ∈ TwoSidedIdeal.span + {z : C | ∃ a ∈ H, ∃ b ∈ H, a * b = z} at hz + rw [TwoSidedIdeal.mem_span_iff] at hz + exact hz (actionAnnihilator (C := C) (W := W)) (by + rintro z ⟨a, ha, b, hb, rfl⟩ + exact (mem_actionAnnihilator_iff (C := C) (W := W)).2 (hprod a ha b hb)) + +/-- Scalar multiplication by the quotient ring, when the quotient ideal acts +trivially. -/ +def quotientSMul (J : TwoSidedIdeal C) + (hJ : J ≤ actionAnnihilator (C := C) (W := W)) : + SMul J.ringCon.Quotient W where + smul q w := q.liftOn (fun a : C => a • w) (by + intro a b hab + have hsub : (a - b) • w = 0 := + (mem_actionAnnihilator_iff (C := C) (W := W)).1 + (hJ ((J.rel_iff a b).1 hab)) w + rw [sub_smul] at hsub + exact sub_eq_zero.mp hsub) + +/-- The original module action descended through a noncommutative two-sided +quotient. -/ +def quotientModule (J : TwoSidedIdeal C) + (hJ : J ≤ actionAnnihilator (C := C) (W := W)) : + Module J.ringCon.Quotient W := by + letI : SMul J.ringCon.Quotient W := quotientSMul J hJ + exact Function.Surjective.moduleLeft J.ringCon.mk' + Quotient.mk''_surjective (by + intro a w + rfl) + +@[simp] +theorem quotient_mk_smul (J : TwoSidedIdeal C) + (hJ : J ≤ actionAnnihilator (C := C) (W := W)) + (a : C) (w : W) : + letI := quotientModule J hJ + J.ringCon.mk' a • w = a • w := by + change (quotientSMul J hJ).smul (J.ringCon.mk' a) w = a • w + rfl + +variable {T : Type*} [Ring T] + +/-- A ring homomorphism that kills a two-sided ideal descends through its +ring-congruence quotient. -/ +def quotientRingHom (J : TwoSidedIdeal C) (f : C →+* T) + (hf : ∀ a ∈ J, f a = 0) : J.ringCon.Quotient →+* T where + toFun q := q.liftOn f (by + intro a b hab + have hz : f (a - b) = 0 := hf (a - b) ((J.rel_iff a b).1 hab) + rw [map_sub] at hz + exact sub_eq_zero.mp hz) + map_zero' := f.map_zero + map_one' := f.map_one + map_add' x y := Quotient.inductionOn₂' x y fun a b => f.map_add a b + map_mul' x y := Quotient.inductionOn₂' x y fun a b => f.map_mul a b + +@[simp] +theorem quotientRingHom_mk (J : TwoSidedIdeal C) (f : C →+* T) + (hf : ∀ a ∈ J, f a = 0) (a : C) : + quotientRingHom J f hf (J.ringCon.mk' a) = f a := by + unfold quotientRingHom + rfl + +end AbstractQuotientAction + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] +variable [IsLocalRing (Localization S)] + +local notation "Cₗ" => + OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ) +local notation "Wₗ" => LocalizedDeformationModule D S +local notation "A₀" => Localization S +local notation "𝔪" => IsLocalRing.maximalIdeal A₀ + +/-- The pullback `H` of the annihilating maximal-ideal power. It is a +two-sided ideal because it is formed by comapping the corresponding +two-sided ideal of the commutative special fibre. -/ +def localizedHighPowerPullback (q : ℕ) : TwoSidedIdeal Cₗ := + TwoSidedIdeal.comap (localizedOppositeSpecialization D S) + (TwoSidedIdeal.fromIdeal (𝔪 ^ q)) + +theorem mem_localizedHighPowerPullback_iff (q : ℕ) (a : Cₗ) : + a ∈ localizedHighPowerPullback D S q ↔ + localizedOppositeSpecialization D S a ∈ 𝔪 ^ q := by + rw [localizedHighPowerPullback, TwoSidedIdeal.mem_comap] + have h := (TwoSidedIdeal.orderIsoIdeal (R := A₀)).right_inv (𝔪 ^ q) + change localizedOppositeSpecialization D S a ∈ + TwoSidedIdeal.asIdeal (TwoSidedIdeal.fromIdeal (𝔪 ^ q)) ↔ _ + exact SetLike.ext_iff.mp h (localizedOppositeSpecialization D S a) + +/-- The genuine noncommutative two-block ideal `J`. -/ +def localizedTwoBlockIdeal (q : ℕ) : TwoSidedIdeal Cₗ := + twoBlockIdeal (localizedHighPowerPullback D S q) + +/-- The doubled commutative power used as the specialization target. -/ +def localizedDoubledPower (q : ℕ) : Ideal A₀ := + (𝔪 ^ q) * (𝔪 ^ q) + +/-- Specialization followed by the commutative doubled-power quotient. -/ +def localizedDoubledPowerSpecialization (q : ℕ) : + Cₗ →+* A₀ ⧸ localizedDoubledPower S q := + (Ideal.Quotient.mk (localizedDoubledPower S q)).comp + (localizedOppositeSpecialization D S) + +/-- The two-block ideal lies in the kernel of doubled-power specialization. -/ +theorem localizedTwoBlockIdeal_le_doubledPowerSpecializationKernel + (q : ℕ) : + ∀ z ∈ localizedTwoBlockIdeal D S q, + localizedDoubledPowerSpecialization D S q z = 0 := by + intro z hz + change z ∈ TwoSidedIdeal.span + {z : Cₗ | ∃ a ∈ localizedHighPowerPullback D S q, + ∃ b ∈ localizedHighPowerPullback D S q, a * b = z} at hz + rw [TwoSidedIdeal.mem_span_iff] at hz + have hker := hz + (TwoSidedIdeal.ker (localizedDoubledPowerSpecialization D S q)) (by + rintro z ⟨a, ha, b, hb, rfl⟩ + apply (TwoSidedIdeal.mem_ker + (localizedDoubledPowerSpecialization D S q)).2 + rw [map_mul] + change Ideal.Quotient.mk (localizedDoubledPower S q) + (localizedOppositeSpecialization D S a) * + Ideal.Quotient.mk (localizedDoubledPower S q) + (localizedOppositeSpecialization D S b) = 0 + rw [← map_mul, Ideal.Quotient.eq_zero_iff_mem] + exact Ideal.mul_mem_mul + ((mem_localizedHighPowerPullback_iff D S q a).1 ha) + ((mem_localizedHighPowerPullback_iff D S q b).1 hb)) + exact (TwoSidedIdeal.mem_ker + (localizedDoubledPowerSpecialization D S q)).1 hker + +/-- The first load-bearing quotient statement: `J` acts trivially on the +localized deformation module. -/ +theorem localizedTwoBlockIdeal_le_actionAnnihilator + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + localizedTwoBlockIdeal D S q ≤ + actionAnnihilator (C := Cₗ) (W := Wₗ) := by + apply twoBlockIdeal_le_actionAnnihilator + intro a ha b hb w + apply product_smul_eq_zero_of_specializations_mem_annihilator D S a b + · exact hpow ((mem_localizedHighPowerPullback_iff D S q a).1 ha) + · exact hpow ((mem_localizedHighPowerPullback_iff D S q b).1 hb) + +/-- The localized two-block quotient ring. Artinianness is not asserted. -/ +abbrev LocalizedTwoBlockRing (q : ℕ) := + (localizedTwoBlockIdeal D S q).ringCon.Quotient + +/-- The honestly descended ring specialization. Its target is the +commutative doubled-power quotient; no identification of module special +fibres is claimed. -/ +def localizedTwoBlockSpecialization (q : ℕ) : + LocalizedTwoBlockRing D S q →+* + A₀ ⧸ localizedDoubledPower S q := + quotientRingHom (localizedTwoBlockIdeal D S q) + (localizedDoubledPowerSpecialization D S q) + (localizedTwoBlockIdeal_le_doubledPowerSpecializationKernel D S q) + +@[simp] +theorem localizedTwoBlockSpecialization_mk + (q : ℕ) (a : Cₗ) : + localizedTwoBlockSpecialization D S q + ((localizedTwoBlockIdeal D S q).ringCon.mk' a) = + Ideal.Quotient.mk (localizedDoubledPower S q) + (localizedOppositeSpecialization D S a) := by + rfl + +/-- The descended specialization is surjective. -/ +theorem localizedTwoBlockSpecialization_surjective (q : ℕ) : + Function.Surjective (localizedTwoBlockSpecialization D S q) := by + intro y + obtain ⟨r, rfl⟩ := Ideal.Quotient.mk_surjective y + obtain ⟨a, ha⟩ := localizedOppositeSpecialization_surjective D S r + refine ⟨(localizedTwoBlockIdeal D S q).ringCon.mk' a, ?_⟩ + rw [localizedTwoBlockSpecialization_mk, ha] + +/-- The descended action of the two-block quotient ring on the unchanged +localized deformation module. -/ +def localizedTwoBlockModule + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) : + Module (LocalizedTwoBlockRing D S q) Wₗ := + quotientModule (localizedTwoBlockIdeal D S q) + (localizedTwoBlockIdeal_le_actionAnnihilator D S q hpow) + +/-- The descended scalar action, exposed without installing a global instance. -/ +def localizedTwoBlockAction + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) + (a : LocalizedTwoBlockRing D S q) (w : Wₗ) : Wₗ := + (quotientSMul (localizedTwoBlockIdeal D S q) + (localizedTwoBlockIdeal_le_actionAnnihilator D S q hpow)).smul a w + +@[simp] +theorem localizedTwoBlockAction_mk + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) + (a : Cₗ) (w : Wₗ) : + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' a) w = a • w := by + rfl + +/-- The descended parameter still acts by the concrete localized parameter +operator. -/ +theorem localizedTwoBlock_parameter_smul + (q : ℕ) + (hpow : 𝔪 ^ q ≤ + Module.annihilator A₀ (LocalizedModule S G)) + (w : Wₗ) : + localizedTwoBlockAction D S q hpow + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) w = + localizedCAct D S w := by + rw [localizedTwoBlockAction_mk] + rw [localizedCAct_apply] + exact OreLocalization.oreDiv_one_smul _ _ + +/-- The parameter remains square-zero in the two-block quotient. -/ +theorem localizedTwoBlock_parameter_sq + (q : ℕ) : + ((localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c))) ^ 2 = 0 := by + rw [pow_two] + calc + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) * + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c)) = + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op D.c) * + OreLocalization.numeratorRingHom (MulOpposite.op D.c)) := by + exact ((localizedTwoBlockIdeal D S q).ringCon.mk').map_mul _ _ |>.symm + _ = (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom + (MulOpposite.op D.c * MulOpposite.op D.c)) := by + exact congrArg ((localizedTwoBlockIdeal D S q).ringCon.mk') + ((OreLocalization.numeratorRingHom + (S := OppositeDenominators D S) (R := Bᵐᵒᵖ)).map_mul _ _).symm + _ = 0 := by + have hc : D.c * D.c = 0 := by + simpa [pow_two] using D.c_sq + rw [show MulOpposite.op D.c * MulOpposite.op D.c = + MulOpposite.op (D.c * D.c) by rfl, hc] + calc + (localizedTwoBlockIdeal D S q).ringCon.mk' + (OreLocalization.numeratorRingHom (MulOpposite.op 0)) = + (localizedTwoBlockIdeal D S q).ringCon.mk' 0 := by + exact congrArg ((localizedTwoBlockIdeal D S q).ringCon.mk') + ((OreLocalization.numeratorRingHom + (S := OppositeDenominators D S) (R := Bᵐᵒᵖ)).map_zero) + _ = 0 := (localizedTwoBlockIdeal D S q).ringCon.mk'.map_zero + + +end + +end Stafford38.Characteristic.LocalizedTwoBlockQuotient diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimeFiniteLengthLocalization.lean b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimeFiniteLengthLocalization.lean new file mode 100644 index 0000000000..a0ffcf190c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimeFiniteLengthLocalization.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalPrimeFiniteLengthLocalization + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization + +export AlgebraicAnalysis.MinimalPrimeFiniteLengthLocalization (finiteLength_of_maximalIdeal_pow_smul_eq_bot localizedModule_finite localizedModule_nontrivial maximalIdeal_le_radical_map_annihilator map_annihilator_le_localized_annihilator exists_maximalIdeal_pow_le_localized_annihilator localizedModule_isFiniteLength localizedModule_nontrivial_and_isFiniteLength) + +end Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimePoisson.lean b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimePoisson.lean new file mode 100644 index 0000000000..77253e306f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalPrimePoisson.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Ideal.MinimalPrime.Basic +import LeanPool.Stafford38.Stafford38.Characteristic.BaseRelativePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.PostScalarExtensionPoisson + +/-! +# Minimal-prime assembly for base-relative Poisson closure + +This file isolates the commutative-algebra end of the remaining Gabber input. +To prove base-relative Poisson closure of a radical, it is enough to prove the +required bracket membership in every minimal prime over the original ideal. +No integrability statement for those minimal primes is asserted here. +-/ + +namespace Stafford38.Characteristic.MinimalPrimePoisson + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.Geometry.CoisotropicTranslation + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- Componentwise membership in every minimal prime assembles to the exact +base-relative Poisson condition on the radical. This is the final elementary +commutative-algebra step after the genuine Gabber integrability input. -/ +theorem radical_isBaseRelativePoisson_of_minimalPrimes + (J : Ideal (SymbolRing k n)) + (h : ∀ P ∈ J.minimalPrimes, + ∀ f : MvPolynomial (Fin n) k, baseLift f ∈ J.radical → + ∀ g ∈ J.radical, poissonBracket (baseLift f) g ∈ P) : + IsBaseRelativePoisson J.radical := by + intro f hf g hg + rw [← J.sInf_minimalPrimes] + exact Ideal.mem_sInf.mpr fun P hP => h P hP f hf g hg + +/-- Componentwise involutivity is the natural sufficient hypothesis for the +minimal-prime assembly above. The only commutative-algebra input is that the +radical is contained in every prime over the original ideal. -/ +theorem radical_isBaseRelativePoisson_of_minimalPrimes_isInvolutive + (J : Ideal (SymbolRing k n)) + (h : ∀ P ∈ J.minimalPrimes, IsInvolutive P) : + IsBaseRelativePoisson J.radical := by + apply radical_isBaseRelativePoisson_of_minimalPrimes J + intro P hP f hf g hg + have hprime : P.IsPrime := hP.1.1 + have hradical : J.radical ≤ P := hprime.radical_le_iff.mpr hP.1.2 + exact h P hP (baseLift f) (hradical hf) g (hradical hg) + + +end + +end Stafford38.Characteristic.MinimalPrimePoisson diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportExistence.lean b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportExistence.lean new file mode 100644 index 0000000000..9d2f23fcc9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportExistence.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportExistence + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.MinimalSupportExistence + +export AlgebraicAnalysis.MinimalSupportExistence (exists_minimal_support_prime) + +end Stafford38.Characteristic.MinimalSupportExistence diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportKernelCokernelLengths.lean b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportKernelCokernelLengths.lean new file mode 100644 index 0000000000..c9e73c8cfe --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/MinimalSupportKernelCokernelLengths.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MinimalSupportKernelCokernelLengths +import LeanPool.Stafford38.Stafford38.Characteristic.EndomorphismKernelSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic + +export AlgebraicAnalysis (localized_kernel_and_cokernel_isFiniteLength) + +end Stafford38.Characteristic diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/MonicAnnihilatorFinite.lean b/LeanPool/Stafford38/Stafford38/Characteristic/MonicAnnihilatorFinite.lean new file mode 100644 index 0000000000..92c0d92cd9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/MonicAnnihilatorFinite.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.MonicAnnihilatorFinite + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.MonicAnnihilatorFinite + +export AlgebraicAnalysis.MonicAnnihilatorFinite (finite_of_monic_annihilator finite_of_variable_annihilates finite_kernel_and_cokernel_variable) + +end Stafford38.Characteristic.MonicAnnihilatorFinite diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/NoncharacteristicMinimalPrime.lean b/LeanPool/Stafford38/Stafford38/Characteristic/NoncharacteristicMinimalPrime.lean new file mode 100644 index 0000000000..e27d3fb4fc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/NoncharacteristicMinimalPrime.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.GabberGlobalAssembly +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalAxisSupport + +namespace Stafford38.Characteristic.NoncharacteristicMinimalPrime + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.Characteristic.CanonicalNormalAxisSupport +open Stafford38.Characteristic.GabberGlobalAssembly +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.CharacteristicInitialIdeal +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford38.Geometry.ConormalAxisContradiction +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +variable {k : Type*} [Field k] [CharZero k] {n N : ℕ} + +private def iterPderiv (i : PhaseVar (n + 1)) (r : ℕ) + (f : SymbolRing k (n + 1)) : SymbolRing k (n + 1) := + (MvPolynomial.pderiv i)^[r] f + +private theorem iterPderiv_mem_of_involutive + (P : Ideal (SymbolRing k (n + 1))) (hP : IsInvolutive P) + (j : Fin (n + 1)) (hx : MvPolynomial.X (.inl j) ∈ P) + (f : SymbolRing k (n + 1)) (hf : f ∈ P) : + ∀ r, iterPderiv (.inr j) r f ∈ P := by + intro r + induction r with + | zero => simpa [iterPderiv] using hf + | succ r ihr => + have hb := hP (MvPolynomial.X (.inl j)) hx + (iterPderiv (.inr j) r f) ihr + simpa [iterPderiv, Function.iterate_succ_apply', poissonBracket, + Pi.single_apply] using hb + +private theorem iterPderiv_eq_factorial_of_homogeneous + (i : PhaseVar (n + 1)) (f : SymbolRing k (n + 1)) + (hf : f.IsHomogeneous N) + (hc : MvPolynomial.coeff (Finsupp.single i N) f = 1) : + iterPderiv i N f = MvPolynomial.C (N.factorial : k) := by + have hhom : ∀ r, (iterPderiv i r f).IsHomogeneous (N - r) := by + intro r + induction r with + | zero => simpa [iterPderiv] using hf + | succ r ihr => + simpa [iterPderiv, Function.iterate_succ_apply', Nat.sub_sub] using + (MvPolynomial.IsHomogeneous.pderiv ihr) + have hcoeff : ∀ r m, + MvPolynomial.coeff (Finsupp.single i m) (iterPderiv i r f) = + MvPolynomial.coeff (Finsupp.single i (m + r)) f * + ((m + r).descFactorial r : k) := by + intro r + induction r with + | zero => intro m; simp [iterPderiv] + | succ r ihr => + intro m + rw [show iterPderiv i (r + 1) f = + MvPolynomial.pderiv i (iterPderiv i r f) by + simp [iterPderiv, Function.iterate_succ_apply']] + rw [MvPolynomial.coeff_pderiv] + have hi := ihr (m + 1) + simp only [Finsupp.single_add] at hi ⊢ + rw [hi] + have harg : + ((Finsupp.single i m + Finsupp.single i 1) + Finsupp.single i r) = + Finsupp.single i (m + (r + 1)) := by + ext q + by_cases hq : q = i <;> simp [hq] <;> omega + rw [harg] + rw [show m + (r + 1) = m + 1 + r by omega, + Nat.descFactorial_succ] + have hnat : m + 1 + r - r = m + 1 := by omega + rw [hnat] + simp [Nat.add_assoc, Nat.cast_mul] + have hcarg : + Finsupp.single i m + (Finsupp.single i 1 + Finsupp.single i r) = + Finsupp.single i m + (Finsupp.single i r + Finsupp.single i 1) := by + ext q + by_cases hq : q = i <;> simp [hq] <;> omega + rw [hcarg] + ring + have hzero : iterPderiv i N f = + MvPolynomial.C (MvPolynomial.coeff (0 : PhaseVar (n + 1) →₀ ℕ) + (iterPderiv i N f)) := by + calc + iterPderiv i N f = MvPolynomial.homogeneousComponent 0 + (iterPderiv i N f) := by + simpa only [Nat.sub_self] using + (MvPolynomial.homogeneousComponent_eq_self (hhom N)).symm + _ = _ := MvPolynomial.homogeneousComponent_zero _ + rw [hzero] + have hzeroCoeff : + MvPolynomial.coeff (0 : PhaseVar (n + 1) →₀ ℕ) (iterPderiv i N f) = + MvPolynomial.coeff (Finsupp.single i 0) (iterPderiv i N f) := by + congr 1 + ext q + by_cases hq : q = i <;> simp [hq] + rw [hzeroCoeff, hcoeff N 0] + simp [Nat.zero_add, Nat.descFactorial_self, hc] + +theorem canonical_minimalPrime_mem_of_normalCoordinate_false + (d : PresentedWeyl k (n + 1)) + (hN : 0 < N) (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {P : Ideal (SymbolRing k (n + 1))} (hP : P ∈ + (Module.annihilator (SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k + (canonicalRightIdeal (presentedCoordinate k n) d N))).minimalPrimes) : + MvPolynomial.X (.inl (0 : Fin (n + 1))) ∉ P := by + have hPorder : P ∈ (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).minimalPrimes := by + simpa [annihilator_orderAssociatedGradedModule] using hP + letI : P.IsPrime := hP.1.1 + have hInv : IsInvolutive P := minimalPrime_isInvolutive k + (canonicalRightIdeal (presentedCoordinate k n) d N) P hP + intro hx + let f := presentedPrincipalComponent k orderWeight N d + have hf : f ∈ P := by + apply hPorder.1.2 + exact canonical_orderPrincipalComponent_mem_initialIdeal k n N hd + have hderiv := iterPderiv_mem_of_involutive P hInv + (0 : Fin (n + 1)) hx f hf N + have hfac : MvPolynomial.C (N.factorial : k) ∈ P := by + rw [← iterPderiv_eq_factorial_of_homogeneous + (.inr (0 : Fin (n + 1))) f + (canonical_orderPrincipalComponent_isHomogeneous n N hd) + (canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd)] + exact hderiv + have hfac0 : (N.factorial : k) ≠ 0 := by + exact_mod_cast (Nat.factorial_ne_zero N) + have hone : (1 : SymbolRing k (n + 1)) ∈ P := by + have hm := P.mul_mem_left (MvPolynomial.C ((N.factorial : k)⁻¹)) hfac + rw [← MvPolynomial.C_mul, inv_mul_cancel₀ hfac0] at hm + simpa using hm + exact hP.1.1.ne_top ((Ideal.eq_top_iff_one P).mpr hone) + +end +end Stafford38.Characteristic.NoncharacteristicMinimalPrime diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/NormalSymbolPolynomial.lean b/LeanPool/Stafford38/Stafford38/Characteristic/NormalSymbolPolynomial.lean new file mode 100644 index 0000000000..e082e1a7b7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/NormalSymbolPolynomial.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalNormalAxisSupport +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge +import Mathlib.RingTheory.MvPolynomial.Homogeneous + +namespace Stafford38.Characteristic.NormalSymbolPolynomial + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford38.WeylPBWMonicBridge +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Geometry.ConormalAxisContradiction + +noncomputable section +variable {k : Type*} [Field k] + +def normalVariableEquiv (n : ℕ) : + Option {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))} ≃ PhaseVar (n + 1) := + Equiv.optionSubtypeNe (Sum.inr (0 : Fin (n + 1))) + +def normalSymbolAlgEquiv (n : ℕ) : + SymbolRing k (n + 1) ≃ₐ[k] + Polynomial (MvPolynomial + {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))} k) := + (MvPolynomial.renameEquiv k (normalVariableEquiv n).symm).trans + (MvPolynomial.optionEquivLeft k + {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))}) + +def canonicalNormalPolynomial {n N : ℕ} (d : PresentedWeyl k (n + 1)) : + Polynomial (MvPolynomial + {v : PhaseVar (n + 1) // v ≠ Sum.inr (0 : Fin (n + 1))} k) := + normalSymbolAlgEquiv (k := k) n + (presentedPrincipalComponent k (@orderWeight (n + 1)) N d) + +theorem normalSymbolAlgEquiv_normalVariable (n : ℕ) : + normalSymbolAlgEquiv (k := k) n + (MvPolynomial.X (.inr (0 : Fin (n + 1)))) = Polynomial.X := by + simp [normalSymbolAlgEquiv, normalVariableEquiv] + +theorem normalSymbolAlgEquiv_otherVariable (n : ℕ) + (v : PhaseVar (n + 1)) (hv : v ≠ .inr (0 : Fin (n + 1))) : + normalSymbolAlgEquiv (k := k) n (MvPolynomial.X v) = + Polynomial.C (MvPolynomial.X ⟨v, hv⟩) := by + simp [normalSymbolAlgEquiv, normalVariableEquiv, hv] + +theorem optionEquivLeft_monic_of_isHomogeneous + {S : Type*} [Finite S] (P : MvPolynomial (Option S) k) (N : ℕ) + (hP : P.IsHomogeneous N) + (hlead : MvPolynomial.coeff (Finsupp.single none N) P = 1) : + (MvPolynomial.optionEquivLeft k S P).Monic := by + classical + apply Polynomial.monic_of_natDegree_le_of_coeff_eq_one N + · rw [MvPolynomial.natDegree_optionEquivLeft] + exact (MvPolynomial.degreeOf_le_totalDegree P none).trans hP.totalDegree_le + · ext m + rw [MvPolynomial.optionEquivLeft_coeff_coeff] + by_cases hm : m = 0 + · subst m + simpa using hlead + · have hzero : MvPolynomial.coeff (m.optionElim N) P = 0 := by + by_contra hcoeff + have hcoeffHomogeneous : + ((MvPolynomial.optionEquivLeft k S P).coeff N).IsHomogeneous 0 := by + intro e he + rw [MvPolynomial.optionEquivLeft_coeff_coeff] at he + have hdegree := hP he + have hzero : (Finsupp.weight (1 : S → ℕ)) e = 0 := by + by_contra hne + have hpos : 0 < (Finsupp.weight (1 : S → ℕ)) e := Nat.pos_of_ne_zero hne + have hall : N + (Finsupp.weight (1 : S → ℕ)) e = N := by + rw [Finsupp.weight_apply, Finsupp.sum_option_index_smul] at hdegree + simpa [Finsupp.weight_apply] using hdegree + omega + exact hzero + have hcoeff' : MvPolynomial.coeff m + ((MvPolynomial.optionEquivLeft k S P).coeff N) ≠ 0 := by + rwa [MvPolynomial.optionEquivLeft_coeff_coeff] + have hdegree := hcoeffHomogeneous hcoeff' + rw [Finsupp.weight_apply] at hdegree + apply hm + ext x + by_cases hx : x ∈ m.support + · simpa using (Finset.sum_eq_zero_iff_of_nonneg + (fun _ _ ↦ Nat.zero_le _)).mp hdegree x hx + · exact Finsupp.notMem_support_iff.mp hx + rw [hzero] + rw [MvPolynomial.coeff_one, if_neg (Ne.symm hm)] + +theorem canonicalNormalPolynomial_monic {n N : ℕ} + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (canonicalNormalPolynomial (k := k) (n := n) (N := N) d).Monic := by + apply optionEquivLeft_monic_of_isHomogeneous + · exact (canonical_orderPrincipalComponent_isHomogeneous n N hd).rename_isHomogeneous + · change MvPolynomial.coeff (Finsupp.single none N) + (MvPolynomial.rename (normalVariableEquiv n).symm + (presentedPrincipalComponent k orderWeight N d)) = 1 + have hsingle : (Finsupp.single (.inr (0 : Fin (n + 1))) N).mapDomain + (normalVariableEquiv n).symm = Finsupp.single none N := by + simp [normalVariableEquiv] + rw [← hsingle, MvPolynomial.coeff_rename_mapDomain + (normalVariableEquiv n).symm (normalVariableEquiv n).symm.injective] + exact canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd + + +end +end Stafford38.Characteristic.NormalSymbolPolynomial diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJet.lean b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJet.lean new file mode 100644 index 0000000000..858a6f8fb7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJet.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.OrderRees +import Mathlib.Algebra.RingQuot +import Mathlib.RingTheory.TwoSidedIdeal.Kernel +import Mathlib.RingTheory.TwoSidedIdeal.Operations + +/-! +# The order-Rees two-jet ring + +This file constructs only the ring half of the order-Rees two-jet. The +specialization map is defined directly as the finite sum of the order-principal +components of the Rees coefficients. Its multiplication proof retains the +written coefficient order in the noncommutative Weyl algebra. + +No Rees-module action, quotient module, trace package, or Gabber theorem is +constructed here. +-/ + +namespace Stafford38.CharacteristicOrderReesTwoJet + +open Stafford38.Characteristic +open Stafford38.WeylAssociatedGraded +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylOrderRees +open Stafford38.WeylPBW + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The scalar embedding into Rees degree zero. -/ +def orderReesScalarHom : k →+* OrderReesRing (n := n) k where + toFun a := ⟨Polynomial.C (algebraMap k (PresentedWeyl k n) a), by + intro N + by_cases hN : N = 0 + · subst N + rw [Polynomial.coeff_C_zero] + rw [Algebra.algebraMap_eq_smul_one] + exact Submodule.smul_mem _ a (orderPieceOne (n := n) k).property + · rw [Polynomial.coeff_C, if_neg hN] + exact Submodule.zero_mem _⟩ + map_zero' := by ext; simp + map_one' := by ext; simp + map_add' a b := by ext; simp + map_mul' a b := by ext; simp + +/-- The inherited `k`-algebra structure on the order-Rees subring, with +scalars placed in Rees degree zero. -/ +noncomputable instance orderReesRingAlgebra : + Algebra k (OrderReesRing (n := n) k) where + smul a f := orderReesScalarHom (n := n) k a * f + algebraMap := orderReesScalarHom (n := n) k + commutes' a f := by + apply Subtype.ext + change Polynomial.C (algebraMap k (PresentedWeyl k n) a) * + (f : Polynomial (PresentedWeyl k n)) = + (f : Polynomial (PresentedWeyl k n)) * + Polynomial.C (algebraMap k (PresentedWeyl k n) a) + ext N + rw [Polynomial.coeff_C_mul, Polynomial.coeff_mul_C] + exact Algebra.commutes _ _ + smul_def' _ _ := rfl + +/-- The additive finite sum of degreewise order-principal components. -/ +def orderPrincipalSum : + Polynomial (PresentedWeyl k n) →+ SymbolRing k n where + toFun f := f.sum fun N z => + presentedPrincipalComponent k (@orderWeight n) N z + map_zero' := Polynomial.sum_zero_index _ + map_add' f g := Polynomial.sum_add_index f g _ + (fun N => by simp) + (fun N x y => by simp) + +@[simp] theorem orderPrincipalSum_monomial + (N : ℕ) (z : PresentedWeyl k n) : + orderPrincipalSum (n := n) k (Polynomial.monomial N z) = + presentedPrincipalComponent k (@orderWeight n) N z := by + exact Polynomial.sum_monomial_index z _ (by simp) + +/-- On Rees polynomials, the degreewise principal-component sum preserves +multiplication. In the double sum, coefficients occur as `x * y`, in the +same order as in the input product. -/ +theorem orderPrincipalSum_mul + (f g : OrderReesRing (n := n) k) : + orderPrincipalSum (n := n) k + ((f * g : OrderReesRing (n := n) k) : + Polynomial (PresentedWeyl k n)) = + orderPrincipalSum (n := n) k f * + orderPrincipalSum (n := n) k g := by + change orderPrincipalSum (n := n) k + ((f : Polynomial (PresentedWeyl k n)) * + (g : Polynomial (PresentedWeyl k n))) = _ + rw [Polynomial.mul_eq_sum_sum, map_sum] + simp only [Polynomial.sum, map_sum, orderPrincipalSum_monomial] + change + (∑ i ∈ (f : Polynomial (PresentedWeyl k n)).support, + ∑ j ∈ (g : Polynomial (PresentedWeyl k n)).support, + presentedPrincipalComponent k (@orderWeight n) (i + j) + ((f : Polynomial (PresentedWeyl k n)).coeff i * + (g : Polynomial (PresentedWeyl k n)).coeff j)) = + (∑ i ∈ (f : Polynomial (PresentedWeyl k n)).support, + presentedPrincipalComponent k (@orderWeight n) i + ((f : Polynomial (PresentedWeyl k n)).coeff i)) * + (∑ j ∈ (g : Polynomial (PresentedWeyl k n)).support, + presentedPrincipalComponent k (@orderWeight n) j + ((g : Polynomial (PresentedWeyl k n)).coeff j)) + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro i hi + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j hj + exact presentedPrincipalComponent_mul_order k (f.property i) (g.property j) + +/-- Global specialization of the order-Rees ring to its commutative symbol +ring. -/ +def orderReesSpecialization : + OrderReesRing (n := n) k →+* SymbolRing k n where + toFun f := orderPrincipalSum (n := n) k f + map_zero' := by + change orderPrincipalSum (n := n) k + (0 : Polynomial (PresentedWeyl k n)) = 0 + exact map_zero (orderPrincipalSum (n := n) k) + map_add' f g := by + change orderPrincipalSum (n := n) k + ((f : Polynomial (PresentedWeyl k n)) + g) = _ + exact map_add (orderPrincipalSum (n := n) k) + (f : Polynomial (PresentedWeyl k n)) + (g : Polynomial (PresentedWeyl k n)) + map_one' := by + change orderPrincipalSum (n := n) k + (1 : Polynomial (PresentedWeyl k n)) = 1 + rw [show (1 : Polynomial (PresentedWeyl k n)) = Polynomial.monomial 0 1 by + simp] + rw [orderPrincipalSum_monomial] + rw [presentedPrincipalComponent, LinearMap.comp_apply] + change MvPolynomial.weightedHomogeneousComponent (@orderWeight n) 0 + (presentedNormalFormLinearEquiv k n 1) = 1 + rw [Stafford38.WeylPBW.presentedNormalFormLinearEquiv_one] + exact (MvPolynomial.isWeightedHomogeneous_one k (@orderWeight n)).weightedHomogeneousComponent_same + map_mul' := orderPrincipalSum_mul k + +@[simp] theorem orderReesSpecialization_monomial + (N : ℕ) (z : orderPiece k n N) : + orderReesSpecialization (n := n) k (orderReesMonomial k N z) = + presentedPrincipalComponent k (@orderWeight n) N z := by + change orderPrincipalSum (n := n) k + (Polynomial.monomial N (z : PresentedWeyl k n)) = _ + rw [orderPrincipalSum_monomial] + +@[simp] theorem orderReesSpecialization_parameter : + orderReesSpecialization (n := n) k + (orderReesParameter (n := n) k) = 0 := by + rw [orderReesParameter, orderReesSpecialization_monomial] + exact presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight n) (1 : PresentedWeyl k n) + (orderPieceOne (n := n) k).property (by omega) + +/-- Every symbol has a Rees lift. -/ +theorem orderReesSpecialization_surjective : + Function.Surjective (orderReesSpecialization (n := n) k) := by + intro P + induction P using MvPolynomial.induction_on' with + | monomial m a => + let N := monomialWeight (@orderWeight n) m + let z : orderPiece k n N := + ⟨a • Stafford38.WeylPBW.presentedPBWBasis k n m, Submodule.smul_mem _ a + ((presentedPBWBasis_mem_weightPiece_iff k (@orderWeight n) N m).mpr + (le_refl N))⟩ + refine ⟨orderReesMonomial k N z, ?_⟩ + rw [orderReesSpecialization_monomial] + change presentedPrincipalComponent k (@orderWeight n) N + (a • Stafford38.WeylPBW.presentedPBWBasis k n m) = + MvPolynomial.monomial m a + rw [map_smul, presentedPrincipalComponent_basis, if_pos rfl] + rw [MvPolynomial.smul_monomial] + simp + | add P Q hP hQ => + obtain ⟨p, hp⟩ := hP + obtain ⟨q, hq⟩ := hQ + refine ⟨p + q, ?_⟩ + change orderReesSpecialization (n := n) k (p + q) = P + Q + rw [(orderReesSpecialization (n := n) k).map_add, hp, hq] + +@[simp] theorem orderReesSpecialization_scalar (a : k) : + orderReesSpecialization (n := n) k + (orderReesScalarHom (n := n) k a) = + algebraMap k (SymbolRing k n) a := by + change (Polynomial.C (algebraMap k (PresentedWeyl k n) a)).sum + (fun N z => presentedPrincipalComponent k (@orderWeight n) N z) = _ + rw [Polynomial.sum_C_index] + · change MvPolynomial.weightedHomogeneousComponent (@orderWeight n) 0 + (presentedNormalFormLinearEquiv k n + (algebraMap k (PresentedWeyl k n) a)) = _ + rw [Algebra.algebraMap_eq_smul_one, map_smul, + Stafford38.WeylPBW.presentedNormalFormLinearEquiv_one] + rw [map_smul] + rw [(MvPolynomial.isWeightedHomogeneous_one k + (@orderWeight n)).weightedHomogeneousComponent_same] + exact MvPolynomial.C_eq_smul_one.symm + · simp + +/-- The order-Rees specialization as a `k`-algebra homomorphism. -/ +def orderReesSpecializationAlg : + OrderReesRing (n := n) k →ₐ[k] SymbolRing k n := + AlgHom.mk' (orderReesSpecialization (n := n) k) (fun a f => by + change orderReesSpecialization (n := n) k + (orderReesScalarHom (n := n) k a * f) = _ + rw [(orderReesSpecialization (n := n) k).map_mul, + orderReesSpecialization_scalar, Algebra.smul_def]) + +/-- The two-sided ideal generated by the square of the Rees parameter. -/ +def orderReesTwoJetIdeal : TwoSidedIdeal (OrderReesRing (n := n) k) := + TwoSidedIdeal.span + ({orderReesParameter (n := n) k ^ 2} : + Set (OrderReesRing (n := n) k)) + +/-- The order-Rees ring modulo `T²`. -/ +abbrev OrderReesTwoJet := + (orderReesTwoJetIdeal (n := n) k).ringCon.Quotient + +/-- The canonical algebra quotient map to the two-jet. -/ +def orderReesTwoJetQuotient : + OrderReesRing (n := n) k →ₐ[k] OrderReesTwoJet (n := n) k := + AlgHom.mk' (orderReesTwoJetIdeal (n := n) k).ringCon.mk' (fun a r => by + change (orderReesTwoJetIdeal (n := n) k).ringCon.mk' + (orderReesScalarHom (n := n) k a * r) = _ + rw [map_mul] + rfl) + +/-- The image of the Rees parameter in the two-jet. -/ +def orderReesTwoJetParameter : OrderReesTwoJet (n := n) k := + orderReesTwoJetQuotient (n := n) k (orderReesParameter (n := n) k) + +/-- The two-jet parameter is central. -/ +theorem orderReesTwoJetParameter_mem_center : + orderReesTwoJetParameter (n := n) k ∈ + Set.center (OrderReesTwoJet (n := n) k) := by + rw [Semigroup.mem_center_iff] + intro q + obtain ⟨r, rfl⟩ := Quotient.mk''_surjective q + change orderReesTwoJetQuotient (n := n) k r * + orderReesTwoJetQuotient (n := n) k (orderReesParameter (n := n) k) = + orderReesTwoJetQuotient (n := n) k (orderReesParameter (n := n) k) * + orderReesTwoJetQuotient (n := n) k r + rw [← map_mul, ← map_mul, orderReesParameter_mul_comm] + +/-- The two-jet parameter is square-zero. -/ +theorem orderReesTwoJetParameter_sq : + orderReesTwoJetParameter (n := n) k ^ 2 = 0 := by + change orderReesTwoJetQuotient (n := n) k + (orderReesParameter (n := n) k) ^ 2 = 0 + rw [← map_pow] + change (orderReesTwoJetIdeal (n := n) k).ringCon.mk' + (orderReesParameter (n := n) k ^ 2) = + (orderReesTwoJetIdeal (n := n) k).ringCon.mk' 0 + apply Quotient.sound + apply ((orderReesTwoJetIdeal (n := n) k).rel_iff _ _).mpr + have hmem : orderReesParameter (n := n) k ^ 2 ∈ + orderReesTwoJetIdeal (n := n) k := + TwoSidedIdeal.subset_span (Set.mem_singleton _) + simpa using hmem + +theorem orderReesTwoJetIdeal_le_specializationKer : + orderReesTwoJetIdeal (n := n) k ≤ + TwoSidedIdeal.ker (orderReesSpecialization (n := n) k) := by + intro x hx + change x ∈ TwoSidedIdeal.span + ({orderReesParameter (n := n) k ^ 2} : + Set (OrderReesRing (n := n) k)) at hx + rw [TwoSidedIdeal.mem_span_iff] at hx + apply hx + intro z hz + simp only [Set.mem_singleton_iff] at hz + subst z + change orderReesSpecialization (n := n) k + (orderReesParameter (n := n) k ^ 2) = 0 + rw [map_pow, orderReesSpecialization_parameter, + zero_pow (by omega)] + +/-- Specialization factors through the order-Rees two-jet. -/ +def orderReesTwoJetSpecialization : + OrderReesTwoJet (n := n) k →ₐ[k] SymbolRing k n := + let f := orderReesSpecializationAlg (n := n) k + let hrel : ∀ ⦃x y : OrderReesRing (n := n) k⦄, + (orderReesTwoJetIdeal (n := n) k).ringCon x y → f x = f y := by + intro x y hxy + have hmem : x - y ∈ orderReesTwoJetIdeal (n := n) k := + ((orderReesTwoJetIdeal (n := n) k).rel_iff x y).mp hxy + have hker := orderReesTwoJetIdeal_le_specializationKer (n := n) k hmem + rw [TwoSidedIdeal.mem_ker] at hker + have hker' : f (x - y) = 0 := hker + rw [map_sub] at hker' + exact sub_eq_zero.mp hker' + { toFun := Quotient.lift f hrel + map_zero' := f.map_zero + map_one' := f.map_one + map_add' := by + rintro ⟨x⟩ ⟨y⟩ + exact f.map_add x y + map_mul' := by + rintro ⟨x⟩ ⟨y⟩ + exact f.map_mul x y + commutes' := f.commutes } + +@[simp] theorem orderReesTwoJetSpecialization_quotient + (r : OrderReesRing (n := n) k) : + orderReesTwoJetSpecialization (n := n) k + (orderReesTwoJetQuotient (n := n) k r) = + orderReesSpecialization (n := n) k r := by + rfl + +@[simp] theorem orderReesTwoJetSpecialization_parameter : + orderReesTwoJetSpecialization (n := n) k + (orderReesTwoJetParameter (n := n) k) = 0 := by + rw [orderReesTwoJetParameter, + orderReesTwoJetSpecialization_quotient, + orderReesSpecialization_parameter] + +/-- The two-jet specialization remains surjective. -/ +theorem orderReesTwoJetSpecialization_surjective : + Function.Surjective (orderReesTwoJetSpecialization (n := n) k) := by + intro P + obtain ⟨r, hr⟩ := orderReesSpecialization_surjective (n := n) k P + exact ⟨orderReesTwoJetQuotient (n := n) k r, by + rw [orderReesTwoJetSpecialization_quotient, hr]⟩ + + +end + +end Stafford38.CharacteristicOrderReesTwoJet diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetBracket.lean b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetBracket.lean new file mode 100644 index 0000000000..693bceafd5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetBracket.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJet +import LeanPool.Stafford38.Stafford38.Weyl.PBWFirstContraction + +/-! +# The commutator bracket in the order-Rees two-jet + +Every commutator in the order-Rees ring loses one unit of differential order, +so it has an explicit factor of the Rees parameter. This file constructs the +quotient coefficient by coefficient. After specialization, that quotient is +the negative Poisson bracket, with the sign forced by `[x,p] = -1`. + +The quotient is deliberately attached to chosen Rees lifts: modulo `T²`, a +quotient by `T` is only determined modulo `T`. The final theorem therefore +asserts existence for arbitrary two-jet classes while retaining the explicit +source-level witness used to prove it. +-/ + +namespace Stafford38.CharacteristicOrderReesTwoJetBracket + +open Stafford38.Characteristic +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFilteredCommutator +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylOrderRees +open Stafford38.WeylPBWFirstContraction + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The quotient of a homogeneous Rees commutator by one Rees parameter. -/ +def homogeneousCommutatorQuotient + (r s : ℕ) (a : orderPiece k n r) (b : orderPiece k n s) : + OrderReesRing (n := n) k := + if _h : 0 < r + s then + orderReesMonomial k (r + s - 1) + ⟨Stafford.commutator (a : PresentedWeyl k n) b, + commutator_mem_orderPiece_pred k a.property b.property⟩ + else 0 + +/-- Multiplying the homogeneous quotient by `T` recovers the written-order +commutator of the two homogeneous Rees terms. -/ +theorem parameter_mul_homogeneousCommutatorQuotient + (r s : ℕ) (a : orderPiece k n r) (b : orderPiece k n s) : + orderReesParameter (n := n) k * + homogeneousCommutatorQuotient k r s a b = + Stafford.commutator + (orderReesMonomial k r a) (orderReesMonomial k s b) := by + by_cases h : 0 < r + s + · rw [homogeneousCommutatorQuotient, dif_pos h, + orderReesParameter_mul_monomial] + apply Subtype.ext + change Polynomial.monomial ((r + s - 1) + 1) + (Stafford.commutator (a : PresentedWeyl k n) b) = + Polynomial.monomial r (a : PresentedWeyl k n) * + Polynomial.monomial s (b : PresentedWeyl k n) - + Polynomial.monomial s (b : PresentedWeyl k n) * + Polynomial.monomial r (a : PresentedWeyl k n) + simp only [Polynomial.monomial_mul_monomial, Stafford.commutator, + AlgebraicAnalysis.ringCommutator, + ← Polynomial.monomial_sub] + rw [show s + r = r + s by omega] + rw [Nat.sub_add_cancel (by omega : 1 ≤ r + s)] + exact Polynomial.monomial_sub (r + s) + · have hrs : r = 0 ∧ s = 0 := by omega + rcases hrs with ⟨rfl, rfl⟩ + rw [homogeneousCommutatorQuotient, dif_neg (by omega), mul_zero] + have hab := commutator_eq_zero_of_mem_orderPiece_zero + k a.property b.property + apply Subtype.ext + change (0 : Polynomial (PresentedWeyl k n)) = + Polynomial.monomial 0 (a : PresentedWeyl k n) * + Polynomial.monomial 0 (b : PresentedWeyl k n) - + Polynomial.monomial 0 (b : PresentedWeyl k n) * + Polynomial.monomial 0 (a : PresentedWeyl k n) + simp only [Polynomial.monomial_mul_monomial, zero_add, + ← Polynomial.monomial_sub] + rw [show (a : PresentedWeyl k n) * b - b * a = 0 by + simpa [Stafford.commutator, AlgebraicAnalysis.ringCommutator] using hab] + simp + +/-- The homogeneous quotient specializes to the sign-correct negative +Poisson bracket of the two homogeneous principal symbols. -/ +theorem specialization_homogeneousCommutatorQuotient + (r s : ℕ) (a : orderPiece k n r) (b : orderPiece k n s) : + orderReesSpecialization (n := n) k + (homogeneousCommutatorQuotient k r s a b) = + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r a) + (presentedPrincipalComponent k (@orderWeight n) s b) := by + by_cases h : 0 < r + s + · rw [homogeneousCommutatorQuotient, dif_pos h, + orderReesSpecialization_monomial] + exact principalComponent_commutator_eq_neg_poisson + k a.property b.property + · have hrs : r = 0 ∧ s = 0 := by omega + rcases hrs with ⟨rfl, rfl⟩ + rw [homogeneousCommutatorQuotient, dif_neg (by omega), map_zero] + have hcomm := principalComponent_commutator_eq_neg_poisson + k a.property b.property + rw [commutator_eq_zero_of_mem_orderPiece_zero k a.property b.property, + map_zero] at hcomm + exact hcomm + +/-- Explicit source-level quotient of an arbitrary Rees commutator by `T`. +It is the finite double sum of the homogeneous subprincipal commutators. -/ +def orderReesCommutatorQuotient + (a b : OrderReesRing (n := n) k) : OrderReesRing (n := n) k := + ∑ r ∈ (a : Polynomial (PresentedWeyl k n)).support, + ∑ s ∈ (b : Polynomial (PresentedWeyl k n)).support, + homogeneousCommutatorQuotient k r s + ⟨(a : Polynomial (PresentedWeyl k n)).coeff r, a.property r⟩ + ⟨(b : Polynomial (PresentedWeyl k n)).coeff s, b.property s⟩ + +private theorem orderRees_eq_sum_monomials + (a : OrderReesRing (n := n) k) : + a = ∑ r ∈ (a : Polynomial (PresentedWeyl k n)).support, + orderReesMonomial k r + ⟨(a : Polynomial (PresentedWeyl k n)).coeff r, a.property r⟩ := by + apply Subtype.ext + ext N + simp [orderReesMonomial, Polynomial.coeff_monomial] + +private theorem commutator_finset_sum + {R S : Type*} (U : Finset R) (V : Finset S) + (f : R → OrderReesRing (n := n) k) + (g : S → OrderReesRing (n := n) k) : + Stafford.commutator (∑ r ∈ U, f r) (∑ s ∈ V, g s) = + ∑ r ∈ U, ∑ s ∈ V, Stafford.commutator (f r) (g s) := by + simp only [Stafford.commutator, AlgebraicAnalysis.ringCommutator, + Finset.sum_mul, Finset.mul_sum, + Finset.sum_sub_distrib] + rw [Finset.sum_comm] + +/-- The explicit arbitrary witness divides the source commutator by `T`. -/ +theorem parameter_mul_orderReesCommutatorQuotient + (a b : OrderReesRing (n := n) k) : + orderReesParameter (n := n) k * orderReesCommutatorQuotient k a b = + Stafford.commutator a b := by + rw [orderReesCommutatorQuotient, Finset.mul_sum] + simp_rw [Finset.mul_sum, parameter_mul_homogeneousCommutatorQuotient] + rw [← commutator_finset_sum] + rw [← orderRees_eq_sum_monomials k a, + ← orderRees_eq_sum_monomials k b] + +private theorem poissonBracket_finset_sum_left {R : Type*} + (U : Finset R) (f : R → SymbolRing k n) (g : SymbolRing k n) : + poissonBracket (∑ r ∈ U, f r) g = + ∑ r ∈ U, poissonBracket (f r) g := by + classical + induction U using Finset.induction_on with + | empty => simp + | @insert r U hr ih => + rw [Finset.sum_insert hr, Finset.sum_insert hr, + poissonBracket_add_left, ih] + +private theorem poissonBracket_finset_sum_right {S : Type*} + (V : Finset S) (f : SymbolRing k n) (g : S → SymbolRing k n) : + poissonBracket f (∑ s ∈ V, g s) = + ∑ s ∈ V, poissonBracket f (g s) := by + classical + induction V using Finset.induction_on with + | empty => simp + | @insert s V hs ih => + rw [Finset.sum_insert hs, Finset.sum_insert hs, + poissonBracket_add_right, ih] + +private theorem poissonBracket_finset_sum {R S : Type*} + (U : Finset R) (V : Finset S) + (f : R → SymbolRing k n) (g : S → SymbolRing k n) : + poissonBracket (∑ r ∈ U, f r) (∑ s ∈ V, g s) = + ∑ r ∈ U, ∑ s ∈ V, poissonBracket (f r) (g s) := by + rw [poissonBracket_finset_sum_left] + apply Finset.sum_congr rfl + intro r hr + exact poissonBracket_finset_sum_right k V (f r) g + +private theorem orderReesSpecialization_eq_sum + (a : OrderReesRing (n := n) k) : + orderReesSpecialization (n := n) k a = + ∑ r ∈ (a : Polynomial (PresentedWeyl k n)).support, + presentedPrincipalComponent k (@orderWeight n) r + ((a : Polynomial (PresentedWeyl k n)).coeff r) := by + rfl + +/-- The explicit arbitrary quotient specializes to the negative Poisson +bracket of the two Rees specializations. -/ +theorem specialization_orderReesCommutatorQuotient + (a b : OrderReesRing (n := n) k) : + orderReesSpecialization (n := n) k + (orderReesCommutatorQuotient k a b) = + -poissonBracket + (orderReesSpecialization (n := n) k a) + (orderReesSpecialization (n := n) k b) := by + rw [orderReesCommutatorQuotient, map_sum] + simp_rw [map_sum, specialization_homogeneousCommutatorQuotient] + change + (∑ r ∈ (a : Polynomial (PresentedWeyl k n)).support, + ∑ s ∈ (b : Polynomial (PresentedWeyl k n)).support, + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r + ((a : Polynomial (PresentedWeyl k n)).coeff r)) + (presentedPrincipalComponent k (@orderWeight n) s + ((b : Polynomial (PresentedWeyl k n)).coeff s))) = _ + rw [orderReesSpecialization_eq_sum, orderReesSpecialization_eq_sum] + simp_rw [Finset.sum_neg_distrib] + rw [← neg_eq_iff_eq_neg] + simp only [neg_neg] + exact (poissonBracket_finset_sum k _ _ _ _).symm + +/-- An explicit two-jet witness attached to chosen source lifts. -/ +def orderReesTwoJetCommutatorWitness + (a b : OrderReesRing (n := n) k) : OrderReesTwoJet (n := n) k := + orderReesTwoJetQuotient (n := n) k + (orderReesCommutatorQuotient k a b) + +/-- Exact two-jet commutator factorization for chosen Rees lifts. -/ +theorem twoJet_commutator_eq_parameter_mul_witness + (a b : OrderReesRing (n := n) k) : + Stafford.commutator + (orderReesTwoJetQuotient (n := n) k a) + (orderReesTwoJetQuotient (n := n) k b) = + orderReesTwoJetParameter (n := n) k * + orderReesTwoJetCommutatorWitness k a b := by + change orderReesTwoJetQuotient (n := n) k + (Stafford.commutator a b) = + orderReesTwoJetQuotient (n := n) k + (orderReesParameter (n := n) k * + orderReesCommutatorQuotient k a b) + exact congrArg (orderReesTwoJetQuotient (n := n) k) + (parameter_mul_orderReesCommutatorQuotient k a b).symm + +/-- The chosen two-jet witness retains the negative-Poisson specialization. -/ +theorem twoJet_witness_specialization + (a b : OrderReesRing (n := n) k) : + orderReesTwoJetSpecialization (n := n) k + (orderReesTwoJetCommutatorWitness k a b) = + -poissonBracket + (orderReesTwoJetSpecialization (n := n) k + (orderReesTwoJetQuotient (n := n) k a)) + (orderReesTwoJetSpecialization (n := n) k + (orderReesTwoJetQuotient (n := n) k b)) := by + simpa [orderReesTwoJetCommutatorWitness] using + specialization_orderReesCommutatorQuotient k a b + +/-- Every arbitrary two-jet commutator is a parameter multiple, and one may +choose a quotient whose specialization is exactly the negative Poisson bracket +of the specialized inputs. -/ +theorem exists_twoJet_commutatorQuotient + (x y : OrderReesTwoJet (n := n) k) : + ∃ z : OrderReesTwoJet (n := n) k, + Stafford.commutator x y = + orderReesTwoJetParameter (n := n) k * z ∧ + orderReesTwoJetSpecialization (n := n) k z = + -poissonBracket + (orderReesTwoJetSpecialization (n := n) k x) + (orderReesTwoJetSpecialization (n := n) k y) := by + obtain ⟨a, rfl⟩ := Quotient.mk''_surjective x + obtain ⟨b, rfl⟩ := Quotient.mk''_surjective y + exact ⟨orderReesTwoJetCommutatorWitness k a b, + twoJet_commutator_eq_parameter_mul_witness k a b, + twoJet_witness_specialization k a b⟩ + + +end + +end Stafford38.CharacteristicOrderReesTwoJetBracket diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetSpecializationKernel.lean b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetSpecializationKernel.lean new file mode 100644 index 0000000000..bee1539f6d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/OrderReesTwoJetSpecializationKernel.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.OrderReesTwoJet +import Mathlib.Algebra.Polynomial.Inductions + +/-! +# The specialization kernel of the order-Rees two-jet + +The kernel is computed before localization. First, degreewise weighted +homogeneity shows that an order-Rees polynomial with zero principal-symbol +sum has every coefficient one filtration step below its declared degree. +Dividing the polynomial by the central variable `T` therefore stays inside +the order-Rees ring. Passing through the quotient by `T²` gives the exact +elementwise principal-kernel statement for the two-jet. + +The factor is always written on the left. Centrality of `T` is not used to +reverse any noncommutative product. +-/ + +namespace Stafford38.CharacteristicOrderReesTwoJetSpecializationKernel + +open Stafford38.Characteristic +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylOrderRees +open Stafford38.WeylPBW + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- Weighted homogeneity prevents cancellation between distinct declared +Rees degrees in the principal-symbol sum. -/ +private theorem principal_component_eq_zero_of_sum_eq_zero + (r : OrderReesRing (n := n) k) + (hr : orderReesSpecialization (n := n) k r = 0) + (N : ℕ) : + presentedPrincipalComponent k (@orderWeight n) N + ((r : Polynomial (PresentedWeyl k n)).coeff N) = 0 := by + classical + change orderPrincipalSum (n := n) k + (r : Polynomial (PresentedWeyl k n)) = 0 at hr + change (r : Polynomial (PresentedWeyl k n)).sum + (fun M z => presentedPrincipalComponent k (@orderWeight n) M z) = 0 at hr + have hcomponent := congrArg + (MvPolynomial.weightedHomogeneousComponent (@orderWeight n) N) hr + rw [map_zero] at hcomponent + simp only [Polynomial.sum, map_sum] at hcomponent + by_cases hN : N ∈ (r : Polynomial (PresentedWeyl k n)).support + · rw [Finset.sum_eq_single N] at hcomponent + · have hhom : + presentedPrincipalComponent k (@orderWeight n) N + ((r : Polynomial (PresentedWeyl k n)).coeff N) ∈ + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) N := + MvPolynomial.weightedHomogeneousComponent_mem + (@orderWeight n) + (presentedNormalFormLinearEquiv k n + ((r : Polynomial (PresentedWeyl k n)).coeff N)) N + rw [MvPolynomial.weightedHomogeneousComponent_of_mem hhom] at hcomponent + simpa using hcomponent + · intro M hM hMN + have hhom : + presentedPrincipalComponent k (@orderWeight n) M + ((r : Polynomial (PresentedWeyl k n)).coeff M) ∈ + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) M := + MvPolynomial.weightedHomogeneousComponent_mem + (@orderWeight n) + (presentedNormalFormLinearEquiv k n + ((r : Polynomial (PresentedWeyl k n)).coeff M)) M + rw [MvPolynomial.weightedHomogeneousComponent_of_mem hhom] + simp [Ne.symm hMN] + · intro hnot + exact (hnot hN).elim + · have hcoeff : (r : Polynomial (PresentedWeyl k n)).coeff N = 0 := + Polynomial.notMem_support_iff.mp hN + rw [hcoeff, map_zero] + +/-- The kernel of the unquotiented order-Rees specialization is the left +principal ideal generated by the central Rees parameter, stated +elementwise. -/ +theorem orderReesSpecialization_eq_zero_iff_exists_parameter_mul + (r : OrderReesRing (n := n) k) : + orderReesSpecialization (n := n) k r = 0 ↔ + ∃ s : OrderReesRing (n := n) k, + orderReesParameter (n := n) k * s = r := by + constructor + · intro hr + have hlower : ∀ N, + (r : Polynomial (PresentedWeyl k n)).coeff (N + 1) ∈ + orderPiece k n N := by + intro N + have hprincipal := principal_component_eq_zero_of_sum_eq_zero + (n := n) k r hr (N + 1) + have hmem := r.property (N + 1) + exact (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight n) ((r : Polynomial (PresentedWeyl k n)).coeff (N + 1)) + hmem).mp hprincipal + let s : OrderReesRing (n := n) k := + ⟨Polynomial.divX (r : Polynomial (PresentedWeyl k n)), by + intro N + rw [Polynomial.coeff_divX] + exact hlower N⟩ + refine ⟨s, ?_⟩ + apply Subtype.ext + change Polynomial.X * Polynomial.divX + (r : Polynomial (PresentedWeyl k n)) = + (r : Polynomial (PresentedWeyl k n)) + have hconstant : (r : Polynomial (PresentedWeyl k n)).coeff 0 = 0 := by + have hprincipal := principal_component_eq_zero_of_sum_eq_zero + (n := n) k r hr 0 + have hmem := r.property 0 + have hlower0 := (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight n) ((r : Polynomial (PresentedWeyl k n)).coeff 0) + hmem).mp hprincipal + simpa [presentedStrictLowerPiece, Submodule.mem_bot] using hlower0 + simpa [hconstant] using + (Polynomial.X_mul_divX_add (r : Polynomial (PresentedWeyl k n))) + · rintro ⟨s, rfl⟩ + rw [map_mul, orderReesSpecialization_parameter, zero_mul] + +/-- Exact unlocalized specialization kernel for the concrete order-Rees +two-jet: every killed class is a left multiple of the square-zero parameter, +and every such multiple is killed. -/ +theorem orderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + (q : OrderReesTwoJet (n := n) k) : + orderReesTwoJetSpecialization (n := n) k q = 0 ↔ + ∃ b : OrderReesTwoJet (n := n) k, + orderReesTwoJetParameter (n := n) k * b = q := by + constructor + · intro hq + obtain ⟨r, rfl⟩ := Quotient.mk''_surjective q + change orderReesSpecialization (n := n) k r = 0 at hq + obtain ⟨s, hs⟩ := + (orderReesSpecialization_eq_zero_iff_exists_parameter_mul + (n := n) k r).mp hq + refine ⟨orderReesTwoJetQuotient (n := n) k s, ?_⟩ + rw [orderReesTwoJetParameter, ← map_mul, hs] + rfl + · rintro ⟨b, rfl⟩ + rw [map_mul, orderReesTwoJetSpecialization_parameter, zero_mul] + +/-- The same exactness statement in linear-kernel/range form. -/ +theorem orderReesTwoJetSpecialization_ker_eq_range_parameterMul : + LinearMap.ker (orderReesTwoJetSpecialization (n := n) k).toLinearMap = + LinearMap.range + (LinearMap.mulLeft k (orderReesTwoJetParameter (n := n) k)) := by + ext q + rw [LinearMap.mem_ker, LinearMap.mem_range] + exact orderReesTwoJetSpecialization_eq_zero_iff_exists_parameter_mul + (n := n) k q + + +end + +end Stafford38.CharacteristicOrderReesTwoJetSpecializationKernel diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/Polynomial.lean b/LeanPool/Stafford38/Stafford38/Characteristic/Polynomial.lean new file mode 100644 index 0000000000..55de134688 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/Polynomial.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Polynomial phase space for characteristic support + +The order symbol ring of the `n`th Weyl algebra has base variables of fibre +weight zero and cotangent variables of fibre weight one. This file introduces +that ring and its canonical polynomial Poisson bracket without assuming any +characteristic-variety theorem. +-/ + +namespace Stafford38.Characteristic + +/-- Indices for base and cotangent variables. -/ +abbrev PhaseVar (n : ℕ) := Fin n ⊕ Fin n + +/-- Coordinate ring of affine cotangent space. -/ +abbrev SymbolRing (k : Type*) [CommRing k] (n : ℕ) := + MvPolynomial (PhaseVar n) k + +/-- Fibre degree: base variables have weight zero and covariables weight one. -/ +def fibreWeight {n : ℕ} : PhaseVar n → ℕ + | Sum.inl _ => 0 + | Sum.inr _ => 1 + +/-- The standard Poisson bracket on affine cotangent space. -/ +noncomputable def poissonBracket + {k : Type*} [CommRing k] {n : ℕ} + (f g : SymbolRing k n) : SymbolRing k n := + ∑ i : Fin n, + (MvPolynomial.pderiv (Sum.inl i : PhaseVar n) f * + MvPolynomial.pderiv (Sum.inr i : PhaseVar n) g - + MvPolynomial.pderiv (Sum.inr i : PhaseVar n) f * + MvPolynomial.pderiv (Sum.inl i : PhaseVar n) g) + +/-- An ideal is Poisson when it is stable under bracketing with every symbol. -/ +def IsPoisson + {k : Type*} [CommRing k] {n : ℕ} + (J : Ideal (SymbolRing k n)) : Prop := + ∀ f ∈ J, ∀ g, poissonBracket f g ∈ J + +@[simp] theorem poissonBracket_self + {k : Type*} [CommRing k] {n : ℕ} (f : SymbolRing k n) : + poissonBracket f f = 0 := by + simp [poissonBracket, mul_comm] + +end Stafford38.Characteristic diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/PostScalarExtensionPoisson.lean b/LeanPool/Stafford38/Stafford38/Characteristic/PostScalarExtensionPoisson.lean new file mode 100644 index 0000000000..3aa79fc983 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/PostScalarExtensionPoisson.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Poisson closure after scalar extension + +This file transports bracket closure through coefficient extension. Its main +result uses the Gabber-shaped involutivity hypothesis `{J,J} ⊆ J`, rather than +the much stronger project predicate `IsPoisson J = {J,R} ⊆ J`. A second result +transports that stronger predicate by extracting stability under every +coordinate derivation. No claim is made that taking a radical after base +change preserves bracket closure. +-/ + +namespace Stafford38.Characteristic.PostScalarExtensionPoisson + +open Stafford38.Characteristic +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Geometry.CoisotropicTranslation + +noncomputable section + +universe u v + +variable {k : Type u} {K : Type v} +variable [Field k] [Field K] [Algebra k K] +variable {n : ℕ} + +/-- The Gabber-shaped bracket condition: both bracket entries lie in the +ideal. This is weaker than the project predicate `IsPoisson`. -/ +def IsInvolutive (J : Ideal (SymbolRing k n)) : Prop := + ∀ f ∈ J, ∀ g ∈ J, poissonBracket f g ∈ J + +/-- Coefficient extension commutes with the canonical Poisson bracket. -/ +theorem poissonBracket_scalarPolynomialMap + (f g : SymbolRing k n) : + poissonBracket + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) f) + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) g) = + scalarPolynomialMap (k := k) (K := K) (PhaseVar n) + (poissonBracket f g) := by + simp [poissonBracket, scalarPolynomialMap, MvPolynomial.pderiv_map] + +theorem poissonBracket_add_left (f₁ f₂ g : SymbolRing k n) : + poissonBracket (f₁ + f₂) g = + poissonBracket f₁ g + poissonBracket f₂ g := by + simp [poissonBracket, add_mul, Finset.sum_add_distrib] + ring + +theorem poissonBracket_add_right (f g₁ g₂ : SymbolRing k n) : + poissonBracket f (g₁ + g₂) = + poissonBracket f g₁ + poissonBracket f g₂ := by + simp [poissonBracket, mul_add, Finset.sum_add_distrib] + ring + +theorem poissonBracket_mul_left (a f g : SymbolRing k n) : + poissonBracket (a * f) g = + a * poissonBracket f g + f * poissonBracket a g := by + simp only [poissonBracket, MvPolynomial.pderiv_mul] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + +theorem poissonBracket_mul_right (f a g : SymbolRing k n) : + poissonBracket f (a * g) = + a * poissonBracket f g + g * poissonBracket f a := by + simp only [poissonBracket, MvPolynomial.pderiv_mul] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + +/-- Gabber-shaped involutivity is preserved by arbitrary field-valued +coefficient extension. -/ +theorem isInvolutive_map_scalarPolynomialMap + (J : Ideal (SymbolRing k n)) (hJ : IsInvolutive J) : + IsInvolutive + (J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))) := by + let I := J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) + intro f hf + change f ∈ J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) at hf + rw [Ideal.map] at hf + induction hf using Submodule.span_induction with + | mem f hf => + rcases hf with ⟨f₀, hf₀, rfl⟩ + intro g hg + change g ∈ J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) at hg + rw [Ideal.map] at hg + induction hg using Submodule.span_induction with + | mem g hg => + rcases hg with ⟨g₀, hg₀, rfl⟩ + rw [poissonBracket_scalarPolynomialMap] + exact Ideal.mem_map_of_mem _ (hJ f₀ hf₀ g₀ hg₀) + | zero => simp [poissonBracket] + | add g₁ g₂ _ _ hg₁ hg₂ => + rw [poissonBracket_add_right] + exact I.add_mem hg₁ hg₂ + | smul a g hgm hg => + rw [smul_eq_mul, poissonBracket_mul_right] + exact I.add_mem (I.mul_mem_left _ hg) (I.mul_mem_right _ hgm) + | zero => + intro g hg + simp [poissonBracket] + | add f₁ f₂ _ _ hf₁ hf₂ => + intro g hg + rw [poissonBracket_add_left] + exact I.add_mem (hf₁ g hg) (hf₂ g hg) + | smul a f hfm hf => + intro g hg + rw [smul_eq_mul, poissonBracket_mul_left] + exact I.add_mem (I.mul_mem_left _ (hf g hg)) (I.mul_mem_right _ hfm) + +/-- Scalar extension of Gabber-shaped involutivity gives exactly the +base-relative condition consumed by the conormal proof. -/ +theorem isBaseRelativePoisson_map_of_isInvolutive + (J : Ideal (SymbolRing k n)) (hJ : IsInvolutive J) : + BaseRelativePoisson.IsBaseRelativePoisson + (J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))) := by + intro f hf g hg + exact isInvolutive_map_scalarPolynomialMap J hJ (baseLift f) hf g hg + +/-- A Poisson ideal is stable under each phase-space partial derivative. -/ +theorem pderiv_mem_of_isPoisson + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) + {f : SymbolRing k n} (hf : f ∈ J) (i : PhaseVar n) : + MvPolynomial.pderiv i f ∈ J := by + rcases i with i | i + · have h := hJ f hf (MvPolynomial.X (Sum.inr i)) + simpa [poissonBracket, Pi.single_apply] using h + · have h := hJ f hf (MvPolynomial.X (Sum.inl i)) + have hn : -MvPolynomial.pderiv (Sum.inr i) f ∈ J := by + simpa [poissonBracket, Pi.single_apply] using h + simpa using J.neg_mem hn + +/-- Every coordinate derivation preserves the ideal generated after scalar +extension from a Poisson ideal. -/ +theorem pderiv_mem_map_scalarPolynomialMap + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) + {f : SymbolRing K n} + (hf : f ∈ J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))) + (i : PhaseVar n) : + MvPolynomial.pderiv i f ∈ J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) := by + rw [Ideal.map] at hf + induction hf using Submodule.span_induction with + | mem f hf => + rcases hf with ⟨g, hg, rfl⟩ + change MvPolynomial.pderiv i + (MvPolynomial.map (algebraMap k K) g) ∈ _ + rw [MvPolynomial.pderiv_map] + exact Ideal.mem_map_of_mem _ (pderiv_mem_of_isPoisson J hJ hg i) + | zero => simp + | add f g _ _ hf hg => + simpa using (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).add_mem hf hg + | smul a f hfm hf => + rw [smul_eq_mul, MvPolynomial.pderiv_mul] + exact (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).add_mem + ((J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).mul_mem_left _ hfm) + ((J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).mul_mem_left _ hf) + +/-- Full Poisson closure is preserved by arbitrary field-valued coefficient +extension. The target is the actual extended ideal `map`, not its radical. -/ +theorem isPoisson_map_scalarPolynomialMap + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) : + IsPoisson + (J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))) := by + intro f hf g + apply (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).sum_mem + intro i hi + apply (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).sub_mem + · exact (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).mul_mem_right _ + (pderiv_mem_map_scalarPolynomialMap J hJ hf (Sum.inl i)) + · exact (J.map + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).mul_mem_right _ + (pderiv_mem_map_scalarPolynomialMap J hJ hf (Sum.inr i)) + +/-- The transported full Poisson theorem supplies the exact base-relative +fragment used by the conormal argument. -/ +theorem isBaseRelativePoisson_map_scalarPolynomialMap + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) : + BaseRelativePoisson.IsBaseRelativePoisson + (J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))) := + BaseRelativePoisson.IsPoisson.isBaseRelativePoisson _ + (isPoisson_map_scalarPolynomialMap J hJ) + + +end + +end Stafford38.Characteristic.PostScalarExtensionPoisson diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulFiniteTorsion.lean b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulFiniteTorsion.lean new file mode 100644 index 0000000000..fe7ff3e35c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulFiniteTorsion.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulFiniteTorsion +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulPositivity + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.PrincipalKoszulFiniteTorsion + +export AlgebraicAnalysis.PrincipalKoszulFiniteTorsion (isNoetherian_kernel_power isFiniteLength_kernel_power length_cokernel_gt_kernel_of_stable_power_and_nonzero) + +end Stafford38.Characteristic.PrincipalKoszulFiniteTorsion diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulMinimalSupportPositivity.lean b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulMinimalSupportPositivity.lean new file mode 100644 index 0000000000..36e3f581ba --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulMinimalSupportPositivity.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulMinimalSupportPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulSupportOverBase + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.PrincipalKoszulMinimalSupportPositivity + +export AlgebraicAnalysis.PrincipalKoszulMinimalSupportPositivity (length_cokernel_gt_kernel_of_minimal_support) + +end Stafford38.Characteristic.PrincipalKoszulMinimalSupportPositivity diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulPositivity.lean b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulPositivity.lean new file mode 100644 index 0000000000..031dda8c94 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulPositivity.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulPositivity +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.PrincipalKoszulPositivity + +export AlgebraicAnalysis.PrincipalKoszulPositivity (exists_stable_kernel_power exists_stable_kernel_power_smul isArtinian_kernel_power quotient_by_stable_kernel_power_injective length_cokernel_eq_kernel_add_regular_quotient scalar_range_ne_top_of_mem_maximalIdeal length_cokernel_smul_gt_length_kernel_smul length_cokernel_smul_gt_kernel_of_finite_torsion length_cokernel_smul_gt_kernel_of_support_prime) + +end Stafford38.Characteristic.PrincipalKoszulPositivity diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulSupportOverBase.lean b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulSupportOverBase.lean new file mode 100644 index 0000000000..caef4961f2 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/PrincipalKoszulSupportOverBase.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.PrincipalKoszulSupportOverBase +import LeanPool.Stafford38.Stafford38.Characteristic.StableTorsionResidualSupport +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulFiniteTorsion + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.PrincipalKoszulSupportOverBase + +export AlgebraicAnalysis.PrincipalKoszulSupportOverBase (length_cokernel_gt_kernel_of_support_over_base) + +end Stafford38.Characteristic.PrincipalKoszulSupportOverBase diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/RadicalMinimalPrimeInvolutivity.lean b/LeanPool/Stafford38/Stafford38/Characteristic/RadicalMinimalPrimeInvolutivity.lean new file mode 100644 index 0000000000..dd86c730b1 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/RadicalMinimalPrimeInvolutivity.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Ideal.MinimalPrime.Basic +import LeanPool.Stafford38.Stafford38.Characteristic.PostScalarExtensionPoisson + +/-! +# Involutivity descends from a radical to its minimal primes + +Gabber's theorem is stated for the *radical* of the annihilator of an +associated graded module: `{√J, √J} ⊆ √J`. The project interfaces, and the +coisotropic consumers downstream of them, ask instead for involutivity of each +individual minimal prime of `J`. This file supplies the elementary +commutative-algebra step between the two, so that no Gabber-shaped statement +has to be strengthened by hand. + +Two facts are proved. + +* `exists_notMem_mul_mem_radical`: if `P` is minimal over `J` and `f ∈ P`, + then some `s ∉ P` satisfies `s * f ∈ √J`. This is the saturation statement + that replaces localizing at `P`; it is proved directly from the maximally + disjoint prime construction applied to the multiplicative set generated by + `P`'s complement together with `f`, so no Noetherian hypothesis and no + finiteness of the minimal-prime set is used. + +* `minimalPrimes_isInvolutive_of_radical_isInvolutive`: if `√J` is involutive + then every minimal prime of `J` is involutive. With `u = s * t` produced by + the previous lemma for `f` and `g`, the Leibniz rule gives + + ```text + {u f, u g} = u^2 {f, g} + u g {f, u} + u f {u, g}, + ``` + + whose left-hand side lies in `√J ⊆ P` and whose last two summands lie in `P` + because `f, g ∈ P`. Hence `u^2 {f, g} ∈ P`, and `u ∉ P` with `P` prime + gives `{f, g} ∈ P`. + +Nothing here proves involutivity of any concrete radical; this is the +descent step only. +-/ + +namespace Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity + +open Stafford38.Characteristic +open Stafford38.Characteristic.PostScalarExtensionPoisson + +noncomputable section + +section Saturation + +variable {R : Type*} [CommRing R] + +/-- Saturation at a minimal prime. If `P` is minimal over `J` and `f ∈ P`, +some element outside `P` carries `f` into the radical of `J`. This is the +localization-free form of `√(J R_P) = P R_P`. -/ +theorem exists_notMem_mul_mem_radical + {J P : Ideal R} (hP : P ∈ J.minimalPrimes) {f : R} (hf : f ∈ P) : + ∃ s, s ∉ P ∧ s * f ∈ J.radical := by + classical + have hprime : P.IsPrime := hP.1.1 + by_contra hcon + have hcon' : ∀ s : R, s ∉ P → s * f ∉ J.radical := fun s hs hmem => + hcon ⟨s, hs, hmem⟩ + set S : Submonoid R := P.primeCompl ⊔ Submonoid.powers f with hS + have hdisj : Disjoint (J : Set R) (S : Set R) := by + rw [Set.disjoint_left] + rintro x hxJ hxS + rw [SetLike.mem_coe, hS, Submonoid.mem_sup] at hxS + obtain ⟨s, hs, z, hz, rfl⟩ := hxS + obtain ⟨m, rfl⟩ := Submonoid.mem_powers_iff z f |>.mp hz + have hsP : s ∉ P := hs + cases m with + | zero => + rw [pow_zero, mul_one] at hxJ + exact hsP (hP.1.2 hxJ) + | succ m => + refine hcon' s hsP ⟨m + 1, ?_⟩ + have hrw : (s * f) ^ (m + 1) = s ^ m * (s * f ^ (m + 1)) := by ring + rw [hrw] + exact Ideal.mul_mem_left _ _ hxJ + obtain ⟨Q, hQprime, hJQ, hQdisj⟩ := Ideal.exists_le_prime_disjoint J S hdisj + have hQP : Q ≤ P := by + intro x hx + by_contra hxP + exact Set.disjoint_left.mp hQdisj hx + (SetLike.mem_coe.mpr (le_sup_left (a := P.primeCompl) (b := Submonoid.powers f) hxP)) + have hPQ : P ≤ Q := hP.2 ⟨hQprime, hJQ⟩ hQP + exact Set.disjoint_left.mp hQdisj (hPQ hf) + (SetLike.mem_coe.mpr + (le_sup_right (a := P.primeCompl) (b := Submonoid.powers f) (Submonoid.mem_powers f))) + +end Saturation + +section Involutivity + +variable {k : Type*} [Field k] {n : ℕ} + +/-- The Leibniz expansion used by the descent, with `{u, u} = 0` already +cancelled. -/ +theorem sq_mul_poissonBracket_eq + (u f g : SymbolRing k n) : + u * u * poissonBracket f g = + poissonBracket (u * f) (u * g) + - u * (g * poissonBracket f u) - f * (u * poissonBracket u g) := by + rw [poissonBracket_mul_left, poissonBracket_mul_right, + poissonBracket_mul_right u u g, poissonBracket_self] + ring + +/-- Gabber's radical statement implies the minimal-prime statement the +project's coisotropic consumers require. -/ +theorem minimalPrimes_isInvolutive_of_radical_isInvolutive + (J : Ideal (SymbolRing k n)) (h : IsInvolutive J.radical) : + ∀ P ∈ J.minimalPrimes, IsInvolutive P := by + intro P hP f hf g hg + have hprime : P.IsPrime := hP.1.1 + have hrad : J.radical ≤ P := hprime.radical_le_iff.mpr hP.1.2 + obtain ⟨s, hs, hsf⟩ := exists_notMem_mul_mem_radical hP hf + obtain ⟨t, ht, htg⟩ := exists_notMem_mul_mem_radical hP hg + set u : SymbolRing k n := s * t with hu + have huf : u * f ∈ J.radical := by + have hrw : u * f = t * (s * f) := by rw [hu]; ring + rw [hrw] + exact Ideal.mul_mem_left _ _ hsf + have hug : u * g ∈ J.radical := by + have hrw : u * g = s * (t * g) := by rw [hu]; ring + rw [hrw] + exact Ideal.mul_mem_left _ _ htg + have hbr : poissonBracket (u * f) (u * g) ∈ J.radical := h _ huf _ hug + have hmem : u * u * poissonBracket f g ∈ P := by + rw [sq_mul_poissonBracket_eq] + exact sub_mem + (sub_mem (hrad hbr) (Ideal.mul_mem_left _ _ (Ideal.mul_mem_right _ _ hg))) + (Ideal.mul_mem_right _ _ hf) + have huP : u ∉ P := fun hmemu => (hprime.mem_or_mem hmemu).elim hs ht + rcases hprime.mem_or_mem hmem with hsq | hbracket + · exact absurd ((hprime.mem_or_mem hsq).elim id id) huP + · exact hbracket + +end Involutivity + + +end + +end Stafford38.Characteristic.RadicalMinimalPrimeInvolutivity diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ReducedSupportIdeal.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ReducedSupportIdeal.lean new file mode 100644 index 0000000000..62b63af883 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ReducedSupportIdeal.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.BaseRelativePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdeal + +/-! +# The reduced order-characteristic ideal + +This file isolates the commutative ideal carried by the reduced order +characteristic support. It also records its contraction to the base +polynomial ring. These definitions make the remaining base-relative Gabber +statement concrete; no Poisson-closure theorem is asserted here. +-/ + +namespace Stafford38.Characteristic.ReducedSupportIdeal + +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable (k : Type*) [Field k] {n : ℕ} + +/-- The radical of the differential-order initial ideal. -/ +def reducedOrderSupportIdeal + (I : RightIdeal (PresentedWeyl k n)) : Ideal (SymbolRing k n) := + (orderInitialIdeal k I).radical + +/-- The order initial ideal is contained in its reduced support ideal. -/ +theorem orderInitialIdeal_le_reducedOrderSupportIdeal + (I : RightIdeal (PresentedWeyl k n)) : + orderInitialIdeal k I ≤ reducedOrderSupportIdeal k I := + Ideal.le_radical + +/-- Membership in the reduced support ideal is witnessed by a power in the +order initial ideal. -/ +theorem mem_reducedOrderSupportIdeal_iff + (I : RightIdeal (PresentedWeyl k n)) (P : SymbolRing k n) : + P ∈ reducedOrderSupportIdeal k I ↔ + ∃ m : ℕ, P ^ m ∈ orderInitialIdeal k I := + Iff.rfl + +/-- The reduced support ideal is radical. -/ +theorem reducedOrderSupportIdeal_isRadical + (I : RightIdeal (PresentedWeyl k n)) : + (reducedOrderSupportIdeal k I).IsRadical := + Ideal.radical_isRadical _ + +/-- Passing to the radical does not change the order characteristic support. -/ +theorem orderCharacteristicSupport_eq_zeroLocus_reduced + (I : RightIdeal (PresentedWeyl k n)) : + orderCharacteristicSupport k I = + PrimeSpectrum.zeroLocus (reducedOrderSupportIdeal k I) := by + rw [orderCharacteristicSupport_eq_zeroLocus, reducedOrderSupportIdeal, + PrimeSpectrum.zeroLocus_radical] + +/-- The reduced support ideal is intrinsically the vanishing ideal of the +order characteristic support. -/ +theorem vanishingIdeal_orderCharacteristicSupport + (I : RightIdeal (PresentedWeyl k n)) : + PrimeSpectrum.vanishingIdeal (orderCharacteristicSupport k I) = + reducedOrderSupportIdeal k I := by + rw [orderCharacteristicSupport_eq_zeroLocus, reducedOrderSupportIdeal, + PrimeSpectrum.vanishingIdeal_zeroLocus_eq_radical] + +/-- The contraction of the reduced support ideal along the base-coordinate +embedding. This is the precise ideal denoted informally by +`E ∩ k[x₁, …, xₙ]`. -/ +def reducedOrderBaseIdeal + (I : RightIdeal (PresentedWeyl k n)) : Ideal (MvPolynomial (Fin n) k) := + (reducedOrderSupportIdeal k I).comap (baseLift : + MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom + +/-- The base-coordinate lift really is an embedding, so the contraction above +is an honest intersection with the base polynomial subring. -/ +theorem baseLift_injective : + Function.Injective + (baseLift : MvPolynomial (Fin n) k → SymbolRing k n) := + MvPolynomial.rename_injective Sum.inl Sum.inl_injective + +/-- Base-ideal membership is exactly membership of the lifted polynomial in +the reduced support ideal. -/ +theorem mem_reducedOrderBaseIdeal_iff + (I : RightIdeal (PresentedWeyl k n)) (f : MvPolynomial (Fin n) k) : + f ∈ reducedOrderBaseIdeal k I ↔ + baseLift f ∈ reducedOrderSupportIdeal k I := + Iff.rfl + +/-- Contracting after reduction is the same as reducing the contracted order +initial ideal. -/ +theorem reducedOrderBaseIdeal_eq_radical_comap + (I : RightIdeal (PresentedWeyl k n)) : + reducedOrderBaseIdeal k I = + ((orderInitialIdeal k I).comap (baseLift : + MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom).radical := by + simpa [reducedOrderBaseIdeal, reducedOrderSupportIdeal] using + Ideal.comap_radical + ((baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom) + (orderInitialIdeal k I) + +/-- The contracted base ideal is radical. -/ +theorem reducedOrderBaseIdeal_isRadical + (I : RightIdeal (PresentedWeyl k n)) : + (reducedOrderBaseIdeal k I).IsRadical := by + rw [reducedOrderBaseIdeal_eq_radical_comap] + exact Ideal.radical_isRadical _ + +/-- The base contraction may be recovered directly from the characteristic +support, without reference to a chosen presentation of the radical. -/ +theorem reducedOrderBaseIdeal_eq_comap_vanishingIdeal + (I : RightIdeal (PresentedWeyl k n)) : + reducedOrderBaseIdeal k I = + (PrimeSpectrum.vanishingIdeal (orderCharacteristicSupport k I)).comap + (baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom := by + rw [vanishingIdeal_orderCharacteristicSupport] + rfl + +/-- A base polynomial lies in the contracted reduced ideal exactly when its +lift vanishes at every prime of the order characteristic support. -/ +theorem mem_reducedOrderBaseIdeal_iff_forall_support + (I : RightIdeal (PresentedWeyl k n)) (f : MvPolynomial (Fin n) k) : + f ∈ reducedOrderBaseIdeal k I ↔ + ∀ p ∈ orderCharacteristicSupport k I, baseLift f ∈ p.asIdeal := by + rw [reducedOrderBaseIdeal_eq_comap_vanishingIdeal, Ideal.mem_comap, + PrimeSpectrum.mem_vanishingIdeal] + rfl + +/-- The remaining Gabber condition for the reduced characteristic ideal, +written entirely in terms of its base contraction. This is a reformulation, +not a proof, of base-relative Poisson closure. -/ +theorem isBaseRelativePoisson_reduced_iff + (I : RightIdeal (PresentedWeyl k n)) : + IsBaseRelativePoisson (reducedOrderSupportIdeal k I) ↔ + ∀ f ∈ reducedOrderBaseIdeal k I, + ∀ g ∈ reducedOrderSupportIdeal k I, + poissonBracket (baseLift f) g ∈ reducedOrderSupportIdeal k I := by + rfl + + +end + +end Stafford38.Characteristic.ReducedSupportIdeal diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/RightReesArtinianAdapter.lean b/LeanPool/Stafford38/Stafford38/Characteristic/RightReesArtinianAdapter.lean new file mode 100644 index 0000000000..be3095c400 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/RightReesArtinianAdapter.lean @@ -0,0 +1,225 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedFinite +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteSquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroHighPowerReduction +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedRing + +/-! +# The concrete right-Rees Artinian-local adapter + +This file packages the inputs that the concrete order-Rees two-jet already +supplies at a minimal prime of the special-fibre annihilator. The deformation +ring is kept in the actual orientation used by the right module: it is the Ore +localization of the opposite two-jet ring, acting on the left on the localized +module. + +The package contains the localized ring specialization, parameter vanishing, +both exact square-zero sequences, a nonzero finite-length special fibre, and +one maximal-ideal power annihilating that fibre. It does not assume an +Artinian triangular trace theorem. + +One missing localized-action consequence is recorded as +`LocalizedHighPowerTwoBlockVanishing`: two localized deformation blocks whose +specializations lie in the chosen annihilating power must act successively by +zero. The more primitive missing inputs are compatibility of specialization +with the full localized action and exactness of the localized ring map with +kernel generated by the parameter. The latter is needed to identify the ring +modulo its parameter with the commutative local fibre. High-power Artinian +quotient descent and survival of parameter exactness are then separate. No +Artinian quotient action is asserted below. +-/ + +namespace Stafford38.Characteristic.RightReesArtinianAdapter + +open Stafford38.Characteristic +open Stafford38.Characteristic.SquareZeroHighPowerReduction +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.Characteristic.SquareZeroLocalizedRing +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.CharacteristicConcreteSquareZeroTraceData +open Stafford38.CharacteristicFilteredQuotientTwoJet +open Stafford38.CharacteristicOrderReesTwoJet +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CharZero k] +variable [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] +variable [IsLocalRing (Localization S)] +variable [CharZero (Localization S)] +variable [IsNoetherianRing (Localization S)] + +/-- A precise missing localized-action consequence. + +The factors are elements of the actual opposite localized deformation ring, +so their displayed product acts in the same order on the localized right-Rees +module. This statement is deliberately elementwise: it is exactly what is +needed to make the finite sums defining the high-power product ideal act by +zero, without silently postulating a noncommutative ideal quotient. +-/ +def LocalizedHighPowerTwoBlockVanishing (q : ℕ) : Prop := + ∀ {iota : Type*} (s : Finset iota) + (a b : iota → + OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ)) + (_ha : ∀ i ∈ s, + localizedOppositeSpecialization D S (a i) ∈ + IsLocalRing.maximalIdeal (Localization S) ^ q) + (_hb : ∀ i ∈ s, + localizedOppositeSpecialization D S (b i) ∈ + IsLocalRing.maximalIdeal (Localization S) ^ q) + (z : LocalizedDeformationModule D S), + (∑ i ∈ s, a i * b i) • z = 0 + +/-- All pre-Artinian inputs already produced by the localized square-zero +development, before the missing two-block action bridge and quotient. + +The structure is a proposition and introduces no replacement ring or module. +Every field names an equation for the concrete maps in the imported APIs. +Surjectivity and parameter vanishing do not identify the kernel of ring +specialization with the principal parameter ideal. +-/ +structure LocalizedPreArtinianCore : Prop where + base_charZero : CharZero k + localizedFibre_charZero : CharZero (Localization S) + localizedFibre_noetherian : IsNoetherianRing (Localization S) + ringSpecialization_surjective : + Function.Surjective (localizedOppositeSpecialization D S) + ringSpecialization_numerator : + ∀ b : Bᵐᵒᵖ, + localizedOppositeSpecialization D S + (OreLocalization.numeratorHom b) = + algebraMap R (Localization S) (D.pi b.unop) + ringSpecialization_parameter : + localizedOppositeSpecialization D S + (OreLocalization.numeratorHom (MulOpposite.op D.c)) = 0 + parameter_sq : + ∀ z : LocalizedDeformationModule D S, + localizedCAct D S (localizedCAct D S z) = 0 + parameter_fraction : + ∀ (z : N) (s : OppositeDenominators D S), + localizedCAct D S (z /ₒ s) = + (MulOpposite.op D.c • z) /ₒ s + parameter_exact : + AddMonoidHom.ker (localizedCAct D S) = + AddMonoidHom.range (localizedCAct D S) + moduleSpecialization_surjective : + Function.Surjective (localizedSpecialization D S) + moduleSpecialization_fraction : + ∀ (z : N) (s : OppositeDenominators D S), + localizedSpecialization D S (z /ₒ s) = + LocalizedModule.mk (D.rho z) (denominatorMap D S s) + moduleSpecialization_exact : + AddMonoidHom.ker (localizedSpecialization D S) = + AddMonoidHom.range (localizedCAct D S) + fibre_nontrivial : Nontrivial (LocalizedModule S G) + fibre_finiteLength : IsFiniteLength (Localization S) (LocalizedModule S G) + annihilatingPower : + ∃ q : ℕ, + IsLocalRing.maximalIdeal (Localization S) ^ q ≤ + Module.annihilator (Localization S) (LocalizedModule S G) + +/-- Generic assembly of the localized pre-Artinian core from the existing ring, +module, and finite-length APIs. This theorem does not prove +`LocalizedHighPowerTwoBlockVanishing`. +-/ +theorem localizedPreArtinianCore_of_exact_finiteLength + (hnontrivial : Nontrivial (LocalizedModule S G)) + (hlength : IsFiniteLength (Localization S) (LocalizedModule S G)) : + LocalizedPreArtinianCore D S := by + letI : Nontrivial (LocalizedModule S G) := hnontrivial + obtain ⟨q, hq⟩ := + exists_maximalIdeal_pow_le_annihilator_of_finiteLength hlength + exact + { base_charZero := inferInstance + localizedFibre_charZero := inferInstance + localizedFibre_noetherian := inferInstance + ringSpecialization_surjective := + localizedOppositeSpecialization_surjective D S + ringSpecialization_numerator := + localizedOppositeSpecialization_numerator D S + ringSpecialization_parameter := + localizedOppositeSpecialization_parameter D S + parameter_sq := localizedCAct_sq_eq_zero D S + parameter_fraction := localizedCAct_oreDiv D S + parameter_exact := localizedCAct_ker_eq_range D S + moduleSpecialization_surjective := + localizedSpecialization_surjective D S + moduleSpecialization_fraction := by + intro z s + rw [localizedSpecialization_apply, + localizedSpecializationFun_oreDiv] + moduleSpecialization_exact := + localizedSpecialization_ker_eq_range D S + fibre_nontrivial := hnontrivial + fibre_finiteLength := hlength + annihilatingPower := ⟨q, hq⟩ } + +section Concrete + +universe u + +variable (K : Type u) [Field K] [CharZero K] +variable {n : ℕ} + +/-- At every minimal prime over the characteristic-module annihilator, the +concrete right order-Rees two-jet supplies the full localized pre-Artinian core. + +The existentially returned Ore-set instance is the one constructed from the +square-zero commutator factorization. The theorem stops before asserting full +localized-action semilinearity, principal-parameter ring-kernel exactness, +`LocalizedHighPowerTwoBlockVanishing`, or Artinian quotient descent. +-/ +theorem exists_concrete_localizedPreArtinianCore + (I : RightIdeal (PresentedWeyl K n)) + (P : Ideal (SymbolRing K n)) [P.IsPrime] + (hP : P ∈ + (Module.annihilator (SymbolRing K n) + (Stafford38.CharacteristicAssociatedGradedModule.OrderAssociatedGradedModule + K I)).minimalPrimes) : + ∃ h : OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData K I) + P.primeCompl), + letI := h + LocalizedPreArtinianCore + (filteredQuotientTwoJetTraceData K I) P.primeCompl := by + obtain ⟨h, _hexact, hnontrivial, hlength⟩ := + Stafford38.Characteristic.AssociatedGradedFinite.exists_minimalPrimeLocalizedExactnessAndFiniteLength + K I P hP + refine ⟨h, ?_⟩ + letI := h + letI : CharZero (Localization P.primeCompl) := + charZero_of_injective_algebraMap + (FaithfulSMul.algebraMap_injective K + (Localization P.primeCompl)) + letI : IsNoetherianRing (Localization P.primeCompl) := + IsLocalization.isNoetherianRing P.primeCompl + (Localization P.primeCompl) inferInstance + exact localizedPreArtinianCore_of_exact_finiteLength + (filteredQuotientTwoJetTraceData K I) P.primeCompl + hnontrivial hlength + + +end Concrete + +end + +end Stafford38.Characteristic.RightReesArtinianAdapter diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SourceActionCommutatorExpansion.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SourceActionCommutatorExpansion.lean new file mode 100644 index 0000000000..2c0af4f7da --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SourceActionCommutatorExpansion.lean @@ -0,0 +1,487 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteInducedZAction + +/-! +# Commutator expansion for source-row action equations + +This file proves the algebraic calculation between two common-basis first-order +source equations and the induced commutator action on the special fibre. It is +independent of the Weyl presentation, localization, Artinianity, and trace +arguments. + +The deformation module remains only a left module over the noncommutative ring. +The parameter is central and square-zero. Exactness of its action is used only +after the commutator has been expanded. The commutators with the first-order +matrices disappear only after applying the commutative specialization. + +The result records the actual specialized action of the source expansion and +isolates the remaining trace-comparison obligation. It does not assert an +equality with a residue-mapped coefficient matrix. +-/ + +namespace Stafford38.Characteristic.SourceActionCommutatorExpansion + +open Matrix +open Stafford38.Characteristic +open Stafford38.Characteristic.ConcreteEquation33SourceMatrices +open Stafford38.Characteristic.ConcreteInducedZAction +open Stafford38.Characteristic.ArtinianEquation33TraceProducer + +noncomputable section + +universe u + +variable {B Abar W V : Type u} +variable [Ring B] [CommRing Abar] +variable [AddCommGroup W] [Module B W] +variable [AddCommGroup V] [Module Abar V] +variable {r : ℕ} + +local notation "ι" => Fin (r + 1) + +/-- Apply a source-row matrix to a list of lifted basis vectors. The first +index is the input vector and the second index is its output coefficient. -/ +def sourceRowAction (M : Matrix ι ι B) (e : ι → W) (i : ι) : W := + ∑ j, M i j • e j + +theorem smul_sourceRowAction (a : B) (M : Matrix ι ι B) (e : ι → W) (i : ι) : + a • sourceRowAction M e i = ∑ j, (a * M i j) • e j := by + simp only [sourceRowAction] + rw [Finset.smul_sum] + apply Finset.sum_congr rfl + intro j hj + exact (mul_smul a (M i j) (e j)).symm + +theorem sourceRowAction_mul (M N : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction M (fun j => sourceRowAction N e j) i = + sourceRowAction (M * N) e i := by + simp only [sourceRowAction, Matrix.mul_apply] + calc + (∑ j, M i j • ∑ k, N j k • e k) = + ∑ j, ∑ k, M i j • (N j k • e k) := by + apply Finset.sum_congr rfl + intro j hj + rw [Finset.smul_sum] + _ = ∑ j, ∑ k, (M i j * N j k) • e k := by + apply Finset.sum_congr rfl + intro j hj + apply Finset.sum_congr rfl + intro k hk + exact (mul_smul (M i j) (N j k) (e k)).symm + _ = ∑ k, ∑ j, (M i j * N j k) • e k := by + exact Finset.sum_comm + _ = ∑ k, (∑ j, M i j * N j k) • e k := by + apply Finset.sum_congr rfl + intro k hk + rw [Finset.sum_smul] + +theorem sourceRowAction_add (M N : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction (M + N) e i = + sourceRowAction M e i + sourceRowAction N e i := by + simp [sourceRowAction, add_smul, Finset.sum_add_distrib] + +theorem sourceRowAction_sub (M N : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction (M - N) e i = + sourceRowAction M e i - sourceRowAction N e i := by + simp [sourceRowAction, sub_smul, Finset.sum_sub_distrib] + +theorem sourceRowAction_right_scalar + (a : B) (M : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction M (fun j => a • e j) i = + ∑ j, (M i j * a) • e j := by + simp only [sourceRowAction] + apply Finset.sum_congr rfl + intro j hj + exact (mul_smul (M i j) a (e j)).symm + +theorem sourceRowAction_left_scalar + (a : B) (M : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction (fun p q => a * M p q) e i = + a • sourceRowAction M e i := by + rw [smul_sourceRowAction] + rfl + +/-- Move a noncommutative scalar through a source row. The error is the +entrywise scalar commutator. -/ +theorem action_sourceRow_decomp + (a : B) (M : Matrix ι ι B) (e : ι → W) (i : ι) : + a • sourceRowAction M e i = + sourceRowAction M (fun j => a • e j) i + + sourceRowAction (scalarMatrixCommutator a M) e i := by + simp only [sourceRowAction, scalarMatrixCommutator] + rw [Finset.smul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro j hj + simp only [sub_smul] + rw [← mul_smul (M i j) a (e j)] + rw [← sub_smul, ← add_smul] + rw [show M i j * a + (a * M i j - M i j * a) = a * M i j by + noncomm_ring] + exact (mul_smul a (M i j) (e j)).symm + +theorem sourceRowAction_parameter_mul + (c : B) (hcentral : ∀ a : B, c * a = a * c) + (M N : Matrix ι ι B) (e : ι → W) (i : ι) : + sourceRowAction M (fun j => c • sourceRowAction N e j) i = + c • sourceRowAction (M * N) e i := by + simp only [sourceRowAction] + calc + (∑ j, M i j • (c • ∑ k, N j k • e k)) = + ∑ j, c • (M i j • ∑ k, N j k • e k) := by + apply Finset.sum_congr rfl + intro j hj + rw [← mul_smul (M i j) c, + ← hcentral (M i j)] + exact mul_smul c (M i j) _ + _ = c • ∑ j, M i j • ∑ k, N j k • e k := by + rw [Finset.smul_sum] + _ = c • sourceRowAction (M * N) e i := by + congr 1 + exact sourceRowAction_mul M N e i + +theorem sourceRowAction_fun_add + (M : Matrix ι ι B) (f g : ι → W) (i : ι) : + sourceRowAction M (fun j => f j + g j) i = + sourceRowAction M f i + sourceRowAction M g i := by + simp [sourceRowAction, Finset.sum_add_distrib, add_smul] + +theorem action_parameter_comm + (c a : B) (hcentral : ∀ b : B, c * b = b * c) (w : W) : + a • (c • w) = c • (a • w) := by + rw [← mul_smul, ← hcentral a] + exact mul_smul c a w + +/-- Expanding one operator acting on the first-order source equation for a +second operator. -/ +theorem action_on_source_equation + (c x : B) (hcentral : ∀ a : B, c * a = a * c) + (hc2 : c * c = 0) + (A Bm Gamma Theta : Matrix ι ι B) (e : ι → W) + (hx : ∀ j, x • e j = sourceRowAction A e j + + c • sourceRowAction Gamma e j) (i : ι) : + x • (sourceRowAction Bm e i + c • sourceRowAction Theta e i) = + sourceRowAction (Bm * A) e i + c • sourceRowAction (Bm * Gamma) e i + + sourceRowAction (scalarMatrixCommutator x Bm) e i + + c • sourceRowAction (Theta * A) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i := by + have hdouble (w : W) : c • (c • w) = 0 := by + rw [← mul_smul c c, hc2, zero_smul] + have hxe : (fun j => x • e j) = + (fun j => sourceRowAction A e j + c • sourceRowAction Gamma e j) := by + funext j + exact hx j + calc + x • (sourceRowAction Bm e i + c • sourceRowAction Theta e i) = + x • sourceRowAction Bm e i + + x • (c • sourceRowAction Theta e i) := by + simp only [smul_add] + _ = (sourceRowAction Bm (fun j => x • e j) i + + sourceRowAction (scalarMatrixCommutator x Bm) e i) + + c • (sourceRowAction Theta (fun j => x • e j) i + + sourceRowAction (scalarMatrixCommutator x Theta) e i) := by + rw [action_sourceRow_decomp, + action_parameter_comm c x hcentral, + action_sourceRow_decomp] + _ = (sourceRowAction Bm (fun j => sourceRowAction A e j + + c • sourceRowAction Gamma e j) i + + sourceRowAction (scalarMatrixCommutator x Bm) e i) + + c • (sourceRowAction Theta (fun j => sourceRowAction A e j + + c • sourceRowAction Gamma e j) i + + sourceRowAction (scalarMatrixCommutator x Theta) e i) := by + rw [hxe] + _ = sourceRowAction (Bm * A) e i + c • sourceRowAction (Bm * Gamma) e i + + sourceRowAction (scalarMatrixCommutator x Bm) e i + + c • sourceRowAction (Theta * A) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i := by + rw [sourceRowAction_fun_add, sourceRowAction_fun_add, + sourceRowAction_mul, + sourceRowAction_parameter_mul c hcentral Bm Gamma e i, + sourceRowAction_mul, + sourceRowAction_parameter_mul c hcentral Theta Gamma e i] + simp only [smul_add, hdouble, zero_add, add_zero] + abel + +/-- The matrix appearing after the parameter has been removed from the +commutator expansion. The two entrywise scalar commutators are omitted because +they vanish under every commutative ring specialization. -/ +def sourceExpansionMatrix + (X Y Omega : Matrix ι ι B) + (A Bm Gamma Theta : Matrix ι ι B) : Matrix ι ι B := + X - Y + Omega + (Bm * Gamma + Theta * A - A * Theta - Gamma * Bm) + +/-- The unspecialized source-row matrix produced by the commutator expansion. +The two entrywise scalar commutators disappear only after applying a +commutative specialization. -/ +def fullSourceExpansionMatrix + (x y : B) (X Y Omega : Matrix ι ι B) + (A Bm Gamma Theta : Matrix ι ι B) : Matrix ι ι B := + sourceExpansionMatrix X Y Omega A Bm Gamma Theta + + scalarMatrixCommutator x Theta - scalarMatrixCommutator y Gamma + +theorem map_fullSourceExpansionMatrix + (f : B →+* Abar) (x y : B) (X Y Omega : Matrix ι ι B) + (A Bm Gamma Theta : Matrix ι ι B) (i j : ι) : + f (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta i j) = + f (sourceExpansionMatrix X Y Omega A Bm Gamma Theta i j) := by + simp [fullSourceExpansionMatrix, sourceExpansionMatrix, + scalarMatrixCommutator, map_sub, mul_comm] + +/-- After a commutative specialization, the source expansion has zero trace +when the three residue matrices are strictly upper triangular. This is an +algebraic trace statement for the displayed source expansion; it does not +identify that expansion with the induced action on the residual module. -/ +theorem sourceExpansionMatrix_map_trace_eq_zero + (f : B →+* Abar) + (X Y Omega A Bm Gamma Theta : Matrix ι ι B) + (hX : IsStrictUpperTriangularOver X) + (hY : IsStrictUpperTriangularOver Y) + (hOmega : IsStrictUpperTriangularOver Omega) : + Matrix.trace + ((sourceExpansionMatrix X Y Omega A Bm Gamma Theta).map f) = 0 := by + have hR : IsStrictUpperTriangularOver (X - Y + Omega) := by + intro i j hji + simp [hX i j hji, hY i j hji, hOmega i j hji] + have hRmap : IsStrictUpperTriangularOver + ((X - Y + Omega).map f) := by + intro i j hji + simp [Matrix.map_apply, hR i j hji] + have htraceR : Matrix.trace ((X - Y + Omega).map f) = 0 := by + rw [Matrix.trace] + apply Finset.sum_eq_zero + intro i _hi + exact hRmap i i le_rfl + have htraceComm (M N : Matrix ι ι B) : + Matrix.trace ((M * N - N * M).map f) = 0 := by + have hmap : (M * N - N * M).map f = + M.map f * N.map f - N.map f * M.map f := by + ext i j + simp [Matrix.map_apply, Matrix.mul_apply] + rw [hmap, Matrix.trace_sub, Matrix.trace_mul_comm, sub_self] + calc + Matrix.trace ((sourceExpansionMatrix X Y Omega A Bm Gamma Theta).map f) = + Matrix.trace ((X - Y + Omega).map f) + + Matrix.trace ((Bm * Gamma + Theta * A - A * Theta - Gamma * Bm).map f) := by + rw [sourceExpansionMatrix] + have hmap : + ((X - Y + Omega) + + (Bm * Gamma + Theta * A - A * Theta - Gamma * Bm)).map f = + (X - Y + Omega).map f + + (Bm * Gamma + Theta * A - A * Theta - Gamma * Bm).map f := by + ext i j + simp [Matrix.map_apply] + rw [hmap, Matrix.trace_add] + _ = 0 + + Matrix.trace ((Bm * Gamma + Theta * A - A * Theta - Gamma * Bm).map f) := by + rw [htraceR] + _ = 0 := by + have hdecomp : Bm * Gamma + Theta * A - A * Theta - Gamma * Bm = + (Bm * Gamma - Gamma * Bm) + (Theta * A - A * Theta) := by + abel + rw [hdecomp] + have hmap : + ((Bm * Gamma - Gamma * Bm) + (Theta * A - A * Theta)).map f = + (Bm * Gamma - Gamma * Bm).map f + + (Theta * A - A * Theta).map f := by + ext i j + simp [Matrix.map_apply] + rw [hmap, Matrix.trace_add, htraceComm, htraceComm] + simp + +theorem rowAction_congr + (M N : Matrix ι ι B) (e : ι → W) (i : ι) + (h : ∀ p q, M p q = N p q) : + sourceRowAction M e i = sourceRowAction N e i := by + simp only [sourceRowAction] + apply Finset.sum_congr rfl + intro j hj + rw [h i j] + +/-- The exact source-row commutator expansion before specialization. -/ +theorem commutator_on_source_equations + (c x y z : B) (hcentral : ∀ a : B, c * a = a * c) + (hc2 : c * c = 0) + (hxy : x * y - y * x = c * z) + (A Bm Gamma Theta X Y Omega : Matrix ι ι B) (e : ι → W) + (hx : ∀ i, x • e i = sourceRowAction A e i + + c • sourceRowAction Gamma e i) + (hy : ∀ i, y • e i = sourceRowAction Bm e i + + c • sourceRowAction Theta e i) + (hX : ∀ i j, c * X i j = scalarMatrixCommutator x Bm i j) + (hY : ∀ i j, c * Y i j = scalarMatrixCommutator y A i j) + (hOmega : ∀ i j, c * Omega i j = + sourceMatrixCommutator Bm A i j) (i : ι) : + c • (z • e i) = c • sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i := by + have hxy_action : x • (y • e i) = + sourceRowAction (Bm * A) e i + c • sourceRowAction (Bm * Gamma) e i + + sourceRowAction (scalarMatrixCommutator x Bm) e i + + c • sourceRowAction (Theta * A) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i := by + rw [hy i] + exact action_on_source_equation c x hcentral hc2 A Bm Gamma Theta e hx i + have hyx_action : y • (x • e i) = + sourceRowAction (A * Bm) e i + c • sourceRowAction (A * Theta) e i + + sourceRowAction (scalarMatrixCommutator y A) e i + + c • sourceRowAction (Gamma * Bm) e i + + c • sourceRowAction (scalarMatrixCommutator y Gamma) e i := by + rw [hx i] + exact action_on_source_equation c y hcentral hc2 Bm A Theta Gamma e hy i + have hXrow : sourceRowAction (scalarMatrixCommutator x Bm) e i = + c • sourceRowAction X e i := by + calc + sourceRowAction (scalarMatrixCommutator x Bm) e i = + sourceRowAction (fun p q => c * X p q) e i := by + apply rowAction_congr + intro p q + exact (hX p q).symm + _ = c • sourceRowAction X e i := sourceRowAction_left_scalar c X e i + have hYrow : sourceRowAction (scalarMatrixCommutator y A) e i = + c • sourceRowAction Y e i := by + calc + sourceRowAction (scalarMatrixCommutator y A) e i = + sourceRowAction (fun p q => c * Y p q) e i := by + apply rowAction_congr + intro p q + exact (hY p q).symm + _ = c • sourceRowAction Y e i := sourceRowAction_left_scalar c Y e i + have hOmega_row : sourceRowAction (sourceMatrixCommutator Bm A) e i = + c • sourceRowAction Omega e i := by + calc + sourceRowAction (sourceMatrixCommutator Bm A) e i = + sourceRowAction (fun p q => c * Omega p q) e i := by + apply rowAction_congr + intro p q + exact (hOmega p q).symm + _ = c • sourceRowAction Omega e i := sourceRowAction_left_scalar c Omega e i + calc + c • (z • e i) = (c * z) • e i := (mul_smul c z _).symm + _ = (x * y - y * x) • e i := by rw [hxy] + _ = x • (y • e i) - y • (x • e i) := by + rw [sub_smul, mul_smul, mul_smul] + _ = (sourceRowAction (Bm * A) e i + c • sourceRowAction (Bm * Gamma) e i + + sourceRowAction (scalarMatrixCommutator x Bm) e i + + c • sourceRowAction (Theta * A) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i) - + (sourceRowAction (A * Bm) e i + c • sourceRowAction (A * Theta) e i + + sourceRowAction (scalarMatrixCommutator y A) e i + + c • sourceRowAction (Gamma * Bm) e i + + c • sourceRowAction (scalarMatrixCommutator y Gamma) e i) := by + rw [hxy_action, hyx_action] + _ = c • sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i := by + have hBArow : sourceRowAction (Bm * A) e i - + sourceRowAction (A * Bm) e i = c • sourceRowAction Omega e i := by + calc + sourceRowAction (Bm * A) e i - sourceRowAction (A * Bm) e i = + sourceRowAction (sourceMatrixCommutator Bm A) e i := by + simp [sourceMatrixCommutator, sourceRowAction_sub] + _ = c • sourceRowAction Omega e i := hOmega_row + rw [hXrow, hYrow] + calc + (sourceRowAction (Bm * A) e i + c • sourceRowAction (Bm * Gamma) e i + + c • sourceRowAction X e i + c • sourceRowAction (Theta * A) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i) - + (sourceRowAction (A * Bm) e i + c • sourceRowAction (A * Theta) e i + + c • sourceRowAction Y e i + c • sourceRowAction (Gamma * Bm) e i + + c • sourceRowAction (scalarMatrixCommutator y Gamma) e i) = + (sourceRowAction (Bm * A) e i - sourceRowAction (A * Bm) e i) + + (c • sourceRowAction (Bm * Gamma) e i - c • sourceRowAction (A * Theta) e i + + c • sourceRowAction X e i - c • sourceRowAction Y e i + + c • sourceRowAction (Theta * A) e i - c • sourceRowAction (Gamma * Bm) e i + + c • sourceRowAction (scalarMatrixCommutator x Theta) e i - + c • sourceRowAction (scalarMatrixCommutator y Gamma) e i) := by + abel + _ = c • sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i := by + rw [hBArow] + simp [fullSourceExpansionMatrix, sourceExpansionMatrix, + sourceRowAction_add, sourceRowAction_sub, neg_one_smul] + abel_nf + simp [neg_one_smul] + abel + +theorem rho_sourceRowAction + (f : B →+* Abar) (rho : W →+ V) + (hact : ∀ a w, rho (a • w) = f a • rho w) + (M : Matrix ι ι B) (e : ι → W) (i : ι) : + rho (sourceRowAction M e i) = + ∑ j, f (M i j) • rho (e j) := by + simp only [sourceRowAction, map_sum] + apply Finset.sum_congr rfl + intro j hj + exact hact (M i j) (e j) + +/-- After exact parameter descent, the commutator cofactor acts on the special +fibre by the specialized source expansion. This is the precise action-level +conclusion needed before any trace comparison. -/ +theorem rho_commutator_on_source_equations + (c x y z : B) (f : B →+* Abar) (rho : W →+ V) + (hcentral : ∀ a : B, c * a = a * c) + (hc2 : c * c = 0) (hfc : f c = 0) + (hxy : x * y - y * x = c * z) + (hact : ∀ a w, rho (a • w) = f a • rho w) + (hExact : AddMonoidHom.ker + (parameterAct (W := W) c) = + AddMonoidHom.range (parameterAct (W := W) c)) + (A Bm Gamma Theta X Y Omega : Matrix ι ι B) (e : ι → W) + (hx : ∀ i, x • e i = sourceRowAction A e i + + c • sourceRowAction Gamma e i) + (hy : ∀ i, y • e i = sourceRowAction Bm e i + + c • sourceRowAction Theta e i) + (hX : ∀ i j, c * X i j = scalarMatrixCommutator x Bm i j) + (hY : ∀ i j, c * Y i j = scalarMatrixCommutator y A i j) + (hOmega : ∀ i j, c * Omega i j = + sourceMatrixCommutator Bm A i j) (i : ι) : + f z • rho (e i) = + ∑ j, f (sourceExpansionMatrix X Y Omega A Bm Gamma Theta i j) • + rho (e j) := by + have hkill : ∀ w : W, c • w = 0 → rho w = 0 := by + intro w hw + have hwker : w ∈ AddMonoidHom.ker + (parameterAct (W := W) c) := by + exact AddMonoidHom.mem_ker.mpr hw + rw [hExact] at hwker + obtain ⟨v, hv⟩ := hwker + rw [← hv] + change rho (c • v) = 0 + rw [hact, hfc, zero_smul] + have hdouble := commutator_on_source_equations c x y z hcentral hc2 hxy + A Bm Gamma Theta X Y Omega e hx hy hX hY hOmega i + have hparameter : c • + (z • e i - sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i) = 0 := by + rw [smul_sub] + exact sub_eq_zero.mpr hdouble + have hdesc := hkill _ hparameter + have hdesc' : rho (z • e i) = + rho (sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i) := by + rw [map_sub] at hdesc + exact sub_eq_zero.mp hdesc + have hexpansion : f z • rho (e i) = + ∑ j, f (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta i j) • + rho (e j) := by + calc + f z • rho (e i) = rho (z • e i) := (hact z (e i)).symm + _ = rho (sourceRowAction + (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta) e i) := hdesc' + _ = _ := rho_sourceRowAction f rho hact _ _ _ + calc + f z • rho (e i) = + ∑ j, f (fullSourceExpansionMatrix x y X Y Omega A Bm Gamma Theta i j) • + rho (e j) := hexpansion + _ = ∑ j, f (sourceExpansionMatrix X Y Omega A Bm Gamma Theta i j) • + rho (e j) := by + apply Finset.sum_congr rfl + intro j hj + rw [map_fullSourceExpansionMatrix] + + +end + +end Stafford38.Characteristic.SourceActionCommutatorExpansion diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SpecializedNoncharacteristicEquality.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SpecializedNoncharacteristicEquality.lean new file mode 100644 index 0000000000..8ff5834a97 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SpecializedNoncharacteristicEquality.lean @@ -0,0 +1,302 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalAxisMonicInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitPreimageFromInitialTop +import LeanPool.Stafford38.Stafford38.Characteristic.TransposedFilteredModuleSupport + +/-! +# The specialized noncharacteristic boundary for the canonical quotient + +This file closes all algebraic transport around the coordinate-hyperplane +noncharacteristic step. For the canonical quotient it proves that ordinary +coordinate multiplication is surjective after right-to-left transposition, +that transposition fixes the coordinate hyperplane in symbol space, and that +the desired support exclusion is equivalent to surjectivity on the actual +associated graded module. + +The final implication from ordinary surjectivity and the monic normal symbol +to associated-graded surjectivity is not available in Mathlib: it is the +specialized strict noncharacteristic inverse-image theorem. No substitute +for that theorem is assumed here. +-/ + +namespace Stafford38.SpecializedNoncharacteristicEquality + +open Stafford38.CanonicalAxisMonicInitialTop +open Stafford38.CanonicalUnitPreimageFromInitialTop +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicTransposedFilteredModuleSupport +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylQuotientTransport +open Stafford38.WeylTransposition +open Stafford38.WeylTranspositionFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +private abbrev CanonicalIdeal (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + presentedCanonicalRightIdeal (k := k) n N d + +private abbrev AxisCoordinate (n : ℕ) : SymbolRing k (n + 1) := + MvPolynomial.X (.inl (0 : Fin (n + 1))) + +private abbrev AxisZeroLocus (n : ℕ) : + Set (PrimeSpectrum (SymbolRing k (n + 1))) := + PrimeSpectrum.zeroLocus ({AxisCoordinate k n} : + Set (SymbolRing k (n + 1))) + +/-! ## Ordinary transposed restriction -/ + +/-- In the transposed left canonical quotient, left multiplication by the +distinguished coordinate is the original right-coordinate action. -/ +theorem transposedCanonical_coordinate_smul_eq_rightMul + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (q : TransposedFilteredRightQuotient k (CanonicalIdeal k n N d)) : + (presentedCoordinate k n • q).toRightQuotient = + rightMul (CanonicalIdeal k n N d) (presentedCoordinate k n) + q.toRightQuotient := by + rcases q with ⟨q⟩ + change rightMul (CanonicalIdeal k n N d) + (transpose k (n + 1) (presentedCoordinate k n)) q = _ + rw [show presentedCoordinate k n = coordinate k (n + 1) 0 from rfl, + transpose_coordinate] + +/-- PBW monicity already kills ordinary degree-zero restriction of the +transposed left module: coordinate multiplication is onto. -/ +theorem transposedCanonical_coordinate_smul_surjective + [Algebra ℚ k] (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Function.Surjective + (fun q : TransposedFilteredRightQuotient k (CanonicalIdeal k n N d) ↦ + presentedCoordinate k n • q) := by + intro q + obtain ⟨r, hr⟩ := + presentedCanonicalRightQuotient_rightMul_coordinate_surjective + (k := k) n N hd q.toRightQuotient + refine ⟨TransposedFilteredRightQuotient.mk r, ?_⟩ + apply (transposedFilteredRightQuotientEquiv k + (CanonicalIdeal k n N d)).injective + change (presentedCoordinate k n • + TransposedFilteredRightQuotient.mk r).toRightQuotient = + q.toRightQuotient + rw [transposedCanonical_coordinate_smul_eq_rightMul] + exact hr + +/-! ## Symbol-space invariance -/ + +@[simp] theorem symbolTransposition_axisCoordinate (n : ℕ) : + symbolTransposition k (AxisCoordinate k n) = AxisCoordinate k n := by + simp [AxisCoordinate] + +/-- The induced involution on the prime spectrum is literally involutive. -/ +theorem primeComap_symbolTransposition_involutive + {n : ℕ} (p : PrimeSpectrum (SymbolRing k n)) : + PrimeSpectrum.comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom + (PrimeSpectrum.comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom p) = p := by + rw [← PrimeSpectrum.comap_comp_apply] + have hcomp : + (symbolTranspositionEquiv k).toRingEquiv.toRingHom.comp + (symbolTranspositionEquiv k).toRingEquiv.toRingHom = + RingHom.id (SymbolRing k n) := by + apply RingHom.ext + intro P + change symbolTransposition k (symbolTransposition k P) = P + exact AlgHom.congr_fun (symbolTransposition_comp_self k) P + rw [hcomp] + rfl + +/-- Momentum-sign substitution fixes the coordinate hyperplane. -/ +theorem axisZeroLocus_preimage_symbolTransposition (n : ℕ) : + PrimeSpectrum.comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom ⁻¹' + AxisZeroLocus k n = + AxisZeroLocus k n := by + ext p + simp only [Set.mem_preimage, AxisZeroLocus, + PrimeSpectrum.mem_zeroLocus, Set.singleton_subset_iff] + change (symbolTranspositionEquiv k).toRingEquiv.toRingHom + (AxisCoordinate k n) ∈ p.asIdeal ↔ + AxisCoordinate k n ∈ p.asIdeal + change symbolTransposition k (AxisCoordinate k n) ∈ p.asIdeal ↔ + AxisCoordinate k n ∈ p.asIdeal + rw [symbolTransposition_axisCoordinate] + +private theorem disjoint_preimage_iff_of_involution_of_invariant + {X : Type*} (f : X → X) (hf : ∀ x, f (f x) = x) + (A B : Set X) (hB : f ⁻¹' B = B) : + Disjoint (f ⁻¹' A) B ↔ Disjoint A B := by + rw [Set.disjoint_left, Set.disjoint_left] + constructor + · intro h x hxA hxB + have hxpre : f x ∈ f ⁻¹' A := by + change f (f x) ∈ A + rwa [hf] + have hxfb : f x ∈ B := by + have := Set.ext_iff.mp hB x + exact this.mpr hxB + exact h hxpre hxfb + · intro h x hxpre hxB + have hfxB : f x ∈ B := by + have := Set.ext_iff.mp hB x + exact this.mpr hxB + exact h hxpre hfxB + +/-- Consequently, support exclusion from the coordinate hyperplane is +unchanged by the right-to-left symbol transposition. -/ +theorem transposedSupport_disjoint_axis_iff + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + Disjoint + (transposedOrderAssociatedGradedSupport k (CanonicalIdeal k n N d)) + (AxisZeroLocus k n) ↔ + Disjoint + (Module.support (SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k (CanonicalIdeal k n N d))) + (AxisZeroLocus k n) := by + rw [transposedOrderAssociatedGradedSupport_eq_preimage] + apply disjoint_preimage_iff_of_involution_of_invariant + · exact primeComap_symbolTransposition_involutive k + · exact axisZeroLocus_preimage_symbolTransposition k n + +/-! ## Exact remaining strictness boundary -/ + +private theorem disjoint_zeroLocus_singleton_iff_sup_eq_top + {R : Type*} [CommRing R] (I : Ideal R) (x : R) : + Disjoint (PrimeSpectrum.zeroLocus I) + (PrimeSpectrum.zeroLocus ({x} : Set R)) ↔ + I ⊔ Ideal.span {x} = ⊤ := by + rw [Set.disjoint_iff_inter_eq_empty, + ← PrimeSpectrum.zeroLocus_span ({x} : Set R), + ← PrimeSpectrum.zeroLocus_sup, + PrimeSpectrum.zeroLocus_empty_iff_eq_top] + +/-- Since symbol transposition fixes the base coordinate, coordinate +surjectivity on the transposed associated graded module is equivalent to the +same statement on the original associated graded module. -/ +theorem transposedGradedCoordinate_surjective_iff + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + Function.Surjective + (fun q : TransposedOrderAssociatedGradedModule k + (CanonicalIdeal k n N d) ↦ AxisCoordinate k n • q) ↔ + Function.Surjective + (fun q : OrderAssociatedGradedModule k (CanonicalIdeal k n N d) ↦ + AxisCoordinate k n • q) := by + constructor + · intro h q + obtain ⟨r, hr⟩ := h (TransposedOrderAssociatedGradedModule.mk q) + refine ⟨r.toOrderAssociatedGradedModule, ?_⟩ + have hr' := congrArg + TransposedOrderAssociatedGradedModule.toOrderAssociatedGradedModule hr + simpa only [transposedSymbol_smul, symbolTransposition_axisCoordinate] + using hr' + · intro h q + obtain ⟨r, hr⟩ := h q.toOrderAssociatedGradedModule + refine ⟨TransposedOrderAssociatedGradedModule.mk r, ?_⟩ + apply (transposedOrderAssociatedGradedEquiv k + (CanonicalIdeal k n N d)).injective + change TransposedOrderAssociatedGradedModule.toOrderAssociatedGradedModule + (AxisCoordinate k n • + TransposedOrderAssociatedGradedModule.mk r) = + q.toOrderAssociatedGradedModule + simpa only [transposedSymbol_smul, symbolTransposition_axisCoordinate] + using hr + +/-- For the canonical quotient, hyperplane support exclusion is exactly +surjectivity of the coordinate on the actual associated graded module. -/ +theorem canonicalSupport_disjoint_axis_iff_gradedCoordinate_surjective + [Algebra ℚ k] (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + Disjoint + (Module.support (SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k (CanonicalIdeal k n N d))) + (AxisZeroLocus k n) ↔ + Function.Surjective + (fun q : OrderAssociatedGradedModule k (CanonicalIdeal k n N d) ↦ + AxisCoordinate k n • q) := by + have hsupp : + Module.support (SymbolRing k (n + 1)) + (OrderAssociatedGradedModule k (CanonicalIdeal k n N d)) = + PrimeSpectrum.zeroLocus + (orderInitialIdeal k (CanonicalIdeal k n N d)) := by + rw [Module.support_eq_zeroLocus, + annihilator_orderAssociatedGradedModule] + rw [hsupp] + exact (disjoint_zeroLocus_singleton_iff_sup_eq_top + (orderInitialIdeal k (CanonicalIdeal k n N d)) + (AxisCoordinate k n)).trans + (canonical_orderInitialIdeal_sup_coordinate_eq_top_iff_graded_surjective + k n N d) + +/-- Fully transposed form of the exact boundary. This is the strongest +specialized equality obtainable from the current local and Mathlib APIs: +the desired support exclusion is equivalent to strict associated-graded +coordinate surjectivity, while ordinary coordinate surjectivity was proved +above from monicity. -/ +theorem transposedSupport_disjoint_axis_iff_gradedCoordinate_surjective + [Algebra ℚ k] (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + Disjoint + (transposedOrderAssociatedGradedSupport k (CanonicalIdeal k n N d)) + (AxisZeroLocus k n) ↔ + Function.Surjective + (fun q : OrderAssociatedGradedModule k (CanonicalIdeal k n N d) ↦ + AxisCoordinate k n • q) := by + rw [transposedSupport_disjoint_axis_iff] + exact canonicalSupport_disjoint_axis_iff_gradedCoordinate_surjective + k n N d + +/-- Left-module form consumed directly by the missing specialized +noncharacteristic theorem. -/ +theorem transposedSupport_disjoint_axis_iff_transposedGradedCoordinate_surjective + [Algebra ℚ k] (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + Disjoint + (transposedOrderAssociatedGradedSupport k (CanonicalIdeal k n N d)) + (AxisZeroLocus k n) ↔ + Function.Surjective + (fun q : TransposedOrderAssociatedGradedModule k + (CanonicalIdeal k n N d) ↦ AxisCoordinate k n • q) := + (transposedSupport_disjoint_axis_iff_gradedCoordinate_surjective + k n N d).trans (transposedGradedCoordinate_surjective_iff k n N d).symm + +/-- The project-specific algebraic suffix after the noncharacteristic theorem: +transposed support avoidance produces the canonical order-zero predecessor of +the quotient unit. No D-module theorem is used in this conversion. -/ +theorem strictUnitCoordinatePreimage_of_transposedSupport_disjoint_axis + [Algebra ℚ k] (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (havoid : Disjoint + (transposedOrderAssociatedGradedSupport k (CanonicalIdeal k n N d)) + (AxisZeroLocus k n)) : + Stafford38.CanonicalUnitCoordinatePreimage.StrictUnitCoordinatePreimage + k n N d := by + have horiginal := + (transposedSupport_disjoint_axis_iff k n N d).mp havoid + have hzero : Disjoint + (PrimeSpectrum.zeroLocus + (orderInitialIdeal k (CanonicalIdeal k n N d))) + (AxisZeroLocus k n) := by + rw [Module.support_eq_zeroLocus, + annihilator_orderAssociatedGradedModule] at horiginal + exact horiginal + have htop : orderInitialIdeal k (CanonicalIdeal k n N d) ⊔ + Ideal.span {AxisCoordinate k n} = ⊤ := + (disjoint_zeroLocus_singleton_iff_sup_eq_top + (orderInitialIdeal k (CanonicalIdeal k n N d)) + (AxisCoordinate k n)).mp hzero + exact strictUnitCoordinatePreimage_of_orderInitialIdeal_sup_coordinate_eq_top + k n N htop + + +end + +end Stafford38.SpecializedNoncharacteristicEquality diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroAnnihilatorBracket.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroAnnihilatorBracket.lean new file mode 100644 index 0000000000..db85f7ea0c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroAnnihilatorBracket.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroTraceData + +/-! +# Annihilator closure from a square-zero deformation + +The exact parameter sequence already forces the annihilator of the special +fibre to be closed under the recorded first-order bracket. The proof uses +only right-action order, centrality and square-zero exactness; no localization, +trace, finiteness or commutative-algebra hypothesis beyond the existing +commutative special fibre is needed. + +This proves closure only when both bracket inputs lie in the annihilator +itself. It does not prove bracket closure of its radical or of any prime ideal +for inputs that merely lie in that larger ideal. +-/ + +namespace Stafford38.Characteristic.SquareZeroAnnihilatorBracket + +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) + +/-- If the specialization of `a` annihilates `G`, right multiplication by +`a` on the deformation module lands in the image of the parameter action. -/ +theorem rightAction_mem_range_cAct_of_pi_mem_annihilator + {a : B} (ha : D.pi a ∈ Module.annihilator R G) (m : N) : + MulOpposite.op a • m ∈ LinearMap.range D.cAct := by + rw [← D.rho_ker, LinearMap.mem_ker] + rw [D.rho_action] + exact Module.mem_annihilator.mp ha (D.rho m) + +/-- Centrality of the parameter lets every right action pass through its +recorded action on `N`. -/ +theorem rightAction_cAct_comm (a : B) (m : N) : + MulOpposite.op a • D.cAct m = D.cAct (MulOpposite.op a • m) := by + rw [D.cAct_apply, D.cAct_apply, ← mul_smul, ← mul_smul] + change MulOpposite.op (D.c * a) • m = MulOpposite.op (a * D.c) • m + rw [D.c_center.comm a] + +/-- Two successive right actions vanish when both specializations annihilate +the special fibre. The displayed order is literal: first `a`, then `b`. -/ +theorem iterated_rightAction_eq_zero_of_pi_mem_annihilator + {a b : B} + (ha : D.pi a ∈ Module.annihilator R G) + (hb : D.pi b ∈ Module.annihilator R G) (m : N) : + MulOpposite.op b • (MulOpposite.op a • m) = 0 := by + obtain ⟨u, hu⟩ := + rightAction_mem_range_cAct_of_pi_mem_annihilator D ha m + rw [← hu, rightAction_cAct_comm] + obtain ⟨v, hv⟩ := + rightAction_mem_range_cAct_of_pi_mem_annihilator D hb u + rw [← hv] + change (D.cAct.comp D.cAct) v = 0 + rw [D.cAct_comp_self] + rfl + +/-- Consequently the right action of the deformation-ring commutator +vanishes. The reversal `[R_b,R_a] = R_[a,b]` is explicit. -/ +theorem commutator_rightAction_eq_zero_of_pi_mem_annihilator + {a b : B} + (ha : D.pi a ∈ Module.annihilator R G) + (hb : D.pi b ∈ Module.annihilator R G) (m : N) : + MulOpposite.op (Stafford.commutator a b) • m = 0 := by + have hab := + iterated_rightAction_eq_zero_of_pi_mem_annihilator D ha hb m + have hba := + iterated_rightAction_eq_zero_of_pi_mem_annihilator D hb ha m + rw [← rightActionEnd_apply (k := k) (B := B) (N := N), + ← rightAction_commutator (k := k) (B := B) (N := N) a b] + change MulOpposite.op b • (MulOpposite.op a • m) - + MulOpposite.op a • (MulOpposite.op b • m) = 0 + rw [hab, hba, sub_self] + +/-- If `[a,b]=c*z`, then the quotient `z` acts trivially after module +specialization. The explicit left factor `c*z` is essential here: centrality +moves it to the right-module order needed by `cAct`. -/ +theorem rho_rightAction_eq_zero_of_commutator_factor + {a b z : B} + (ha : D.pi a ∈ Module.annihilator R G) + (hb : D.pi b ∈ Module.annihilator R G) + (hz : Stafford.commutator a b = D.c * z) (m : N) : + D.rho (MulOpposite.op z • m) = 0 := by + have hcomm := + commutator_rightAction_eq_zero_of_pi_mem_annihilator D ha hb m + have hcAct : D.cAct (MulOpposite.op z • m) = 0 := by + calc + D.cAct (MulOpposite.op z • m) = + MulOpposite.op D.c • (MulOpposite.op z • m) := D.cAct_apply _ + _ = MulOpposite.op (z * D.c) • m := by rw [← mul_smul]; rfl + _ = MulOpposite.op (D.c * z) • m := by rw [D.c_center.comm z] + _ = MulOpposite.op (Stafford.commutator a b) • m := by rw [hz] + _ = 0 := hcomm + have hm : MulOpposite.op z • m ∈ LinearMap.range D.cAct := by + rw [← D.c_exact, LinearMap.mem_ker] + exact hcAct + rw [← D.rho_ker] at hm + exact LinearMap.mem_ker.mp hm + +/-- The recorded bracket preserves the annihilator of the special fibre in +both inputs. -/ +theorem bracket_mem_annihilator + {x y : R} + (hx : x ∈ Module.annihilator R G) + (hy : y ∈ Module.annihilator R G) : + D.bracket x y ∈ Module.annihilator R G := by + obtain ⟨a, b, z, ha, hb, hz, hbracket⟩ := + RightSquareZeroTraceData.exists_lifts_commutator_factor + (k := k) (B := B) (N := N) D x y + rw [Module.mem_annihilator] + intro g + obtain ⟨m, rfl⟩ := D.rho_surjective g + have hzrho := rho_rightAction_eq_zero_of_commutator_factor D + (ha ▸ hx) (hb ▸ hy) hz m + rw [D.rho_action] at hzrho + simpa [hbracket] using hzrho + + +end + +end Stafford38.Characteristic.SquareZeroAnnihilatorBracket diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroArtinianTruncation.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroArtinianTruncation.lean new file mode 100644 index 0000000000..f2772eb9c9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroArtinianTruncation.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroAnnihilatorBracket + +/-! +# Artinian truncation in a square-zero deformation + +This file isolates the algebraic replacement for the invalid pullback- +filtration division step. If a power of an ideal annihilates the special +fibre, then every deformation-ring element specializing into that power sends +the deformation module into the parameter layer. Two such blocks act by +zero, because the parameter is central and square-zero. + +The result is deliberately stated without a noncommutative ideal on the +deformation ring. Membership is tested after specialization in the +commutative fibre, which is exactly the datum available in the Rees two-jet. +-/ + +namespace Stafford38.Characteristic.SquareZeroArtinianTruncation + +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.Characteristic.SquareZeroAnnihilatorBracket + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) +variable (m : Ideal R) (n : ℕ) + +/-- If `m^n` annihilates the special fibre, a deformation element whose +specialization lies in `m^n` sends every vector into the parameter layer. -/ +theorem rightAction_mem_parameterLayer_of_pi_mem_pow + (hpow : m ^ n ≤ Module.annihilator R G) + {a : B} (ha : D.pi a ∈ m ^ n) (z : N) : + MulOpposite.op a • z ∈ LinearMap.range D.cAct := by + exact rightAction_mem_range_cAct_of_pi_mem_annihilator D (hpow ha) z + +/-- Two blocks specializing into an annihilating ideal power act successively +by zero. This is a two-step parameter-layer statement; it does not say that +every element specializing into `m ^ (2 * n)` acts by zero. -/ +theorem iterated_rightAction_eq_zero_of_pi_mem_pow + (hpow : m ^ n ≤ Module.annihilator R G) + {a b : B} (ha : D.pi a ∈ m ^ n) (hb : D.pi b ∈ m ^ n) (z : N) : + MulOpposite.op b • (MulOpposite.op a • z) = 0 := by + exact iterated_rightAction_eq_zero_of_pi_mem_annihilator D + (hpow ha) (hpow hb) z + +/-- Equivalently, the product of two deformation blocks lying over `m^n` +acts trivially on the deformation module. -/ +theorem product_rightAction_eq_zero_of_pi_mem_pow + (hpow : m ^ n ≤ Module.annihilator R G) + {a b : B} (ha : D.pi a ∈ m ^ n) (hb : D.pi b ∈ m ^ n) (z : N) : + MulOpposite.op (a * b) • z = 0 := by + simpa only [MulOpposite.op_mul, mul_smul] using + iterated_rightAction_eq_zero_of_pi_mem_pow D m n hpow ha hb z + +/-- Every finite sum of two-block products acts trivially. This is the +elementwise ideal-product form needed by an Artinian quotient construction; +no noncommutative ideal API on `B` is required. -/ +theorem sum_products_rightAction_eq_zero_of_pi_mem_pow + {ι : Type*} (s : Finset ι) + (hpow : m ^ n ≤ Module.annihilator R G) + (a b : ι → B) + (ha : ∀ i ∈ s, D.pi (a i) ∈ m ^ n) + (hb : ∀ i ∈ s, D.pi (b i) ∈ m ^ n) (z : N) : + MulOpposite.op (∑ i ∈ s, a i * b i) • z = 0 := by + rw [show MulOpposite.op (∑ i ∈ s, a i * b i) = + ∑ i ∈ s, MulOpposite.op (a i * b i) by + exact map_sum (MulOpposite.opAddEquiv : B ≃+ Bᵐᵒᵖ) _ s] + rw [Finset.sum_smul] + apply Finset.sum_eq_zero + intro i hi + exact product_rightAction_eq_zero_of_pi_mem_pow D m n hpow + (ha i hi) (hb i hi) z + + +end + +end Stafford38.Characteristic.SquareZeroArtinianTruncation diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroHighPowerReduction.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroHighPowerReduction.lean new file mode 100644 index 0000000000..958a1e6127 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroHighPowerReduction.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroArtinianTruncation +import Mathlib.RingTheory.FiniteLength +import Mathlib.RingTheory.LocalRing.Module + +/-! +# High-power reduction for a square-zero deformation + +This file isolates the finite-length reduction used in Singh--Kumar's local +argument. A finite-length module over a commutative local ring is killed by +a power of the maximal ideal. In an exact square-zero deformation, two +blocks lying over that power act successively by zero. Finally, if such a +two-block sum is also a multiple of the deformation parameter, exactness +forces its parameter cofactor to specialize into the maximal ideal. + +The last statement is the elementwise form of the parameter-ideal +intersection used in the high-power quotient argument. It avoids introducing +an artificial multiplication API for two-sided ideals: membership in the +relevant product is recorded by an explicit finite sum of products. +-/ + +namespace Stafford38.Characteristic.SquareZeroHighPowerReduction + +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.Characteristic.SquareZeroArtinianTruncation + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] [IsLocalRing R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +local notation "𝔪" => IsLocalRing.maximalIdeal R + +/-- A finite-length module over a commutative local ring is annihilated by a +power of the maximal ideal. -/ +theorem exists_maximalIdeal_pow_le_annihilator_of_finiteLength + (hG : IsFiniteLength R G) : + ∃ n : ℕ, 𝔪 ^ n ≤ Module.annihilator R G := by + induction hG with + | of_subsingleton => + refine ⟨0, ?_⟩ + intro r _hr + rw [Module.mem_annihilator] + intro g + exact Subsingleton.elim _ _ + | @of_simple_quotient M _ _ S _ _ ih => + obtain ⟨n, hn⟩ := ih + refine ⟨n + 1, ?_⟩ + have hmS : 𝔪 • (⊤ : Submodule R M) ≤ S := by + rw [Submodule.smul_le] + intro r hr g _hg + rw [← Submodule.Quotient.mk_eq_zero S] + have hmax : IsLocalRing.maximalIdeal R = + Module.annihilator R (M ⧸ S) := + (IsLocalRing.eq_maximalIdeal + (IsSimpleModule.annihilator_isMaximal + (R := R) (M := M ⧸ S))).symm + have hrann : r ∈ Module.annihilator R (M ⧸ S) := hmax ▸ hr + exact Module.mem_annihilator.mp hrann (Submodule.Quotient.mk g) + have hpowS : (𝔪 ^ n) • S = ⊥ := by + apply le_antisymm + · calc + (𝔪 ^ n) • S ≤ + Module.annihilator R S • S := + Submodule.smul_mono hn le_rfl + _ = ⊥ := Submodule.annihilator_smul S + · exact bot_le + have hpowM : (𝔪 ^ (n + 1)) • (⊤ : Submodule R M) = ⊥ := by + apply le_antisymm + · rw [pow_succ, mul_smul] + calc + (𝔪 ^ n) • (𝔪 • (⊤ : Submodule R M)) ≤ + (𝔪 ^ n) • S := Submodule.smul_mono le_rfl hmS + _ = ⊥ := hpowS + · exact bot_le + intro r hr + rw [Module.mem_annihilator] + intro g + have hmem : r • g ∈ + (𝔪 ^ (n + 1)) • (⊤ : Submodule R M) := + Submodule.smul_mem_smul hr trivial + have : r • g ∈ (⊥ : Submodule R M) := by + rw [← hpowM] + exact hmem + simpa using this + +/-- If a parameter multiple acts trivially on the deformation module, then +its cofactor specializes into the maximal ideal. This is the exactness and +nonzero-special-fibre step in the parameter-ideal intersection argument. -/ +theorem parameterFactor_mem_maximalIdeal_of_rightAction_eq_zero + [Nontrivial G] + (D : RightSquareZeroTraceData k R B N G) + {z : B} + (hz : ∀ w : N, MulOpposite.op (D.c * z) • w = 0) : + D.pi z ∈ 𝔪 := by + have hpiAnn : D.pi z ∈ Module.annihilator R G := by + rw [Module.mem_annihilator] + intro g + obtain ⟨w, rfl⟩ := D.rho_surjective g + have hcAct : D.cAct (MulOpposite.op z • w) = 0 := by + rw [D.cAct_apply, ← mul_smul] + change MulOpposite.op (z * D.c) • w = 0 + rw [← D.c_center.comm z] + exact hz w + have hrange : MulOpposite.op z • w ∈ LinearMap.range D.cAct := by + rw [← D.c_exact, LinearMap.mem_ker] + exact hcAct + have hrho : D.rho (MulOpposite.op z • w) = 0 := by + rw [← D.rho_ker] at hrange + exact LinearMap.mem_ker.mp hrange + rw [D.rho_action] at hrho + exact hrho + by_contra hnot + have hunit : IsUnit (D.pi z) := IsLocalRing.notMem_maximalIdeal.mp hnot + obtain ⟨g, hg⟩ := exists_ne (0 : G) + have hzero := Module.mem_annihilator.mp hpiAnn g + exact hg (hunit.smul_eq_zero.mp hzero) + +/-- Elementwise parameter-ideal intersection. A finite sum of products of +two blocks over an annihilating power acts by zero; if that sum is `c*z`, then +the parameter cofactor `z` lies over the maximal ideal. -/ +theorem parameterFactor_mem_maximalIdeal_of_eq_sum_products + [Nontrivial G] + (D : RightSquareZeroTraceData k R B N G) + (m : Ideal R) (n : ℕ) + {z : B} {iota : Type*} (s : Finset iota) + (hpow : m ^ n ≤ Module.annihilator R G) + (a b : iota → B) + (ha : ∀ i ∈ s, D.pi (a i) ∈ m ^ n) + (hb : ∀ i ∈ s, D.pi (b i) ∈ m ^ n) + (heq : D.c * z = ∑ i ∈ s, a i * b i) : + D.pi z ∈ 𝔪 := by + apply parameterFactor_mem_maximalIdeal_of_rightAction_eq_zero D + intro w + rw [heq] + exact sum_products_rightAction_eq_zero_of_pi_mem_pow + D m n s hpow a b ha hb w + +/-- The exact high-power descent step. If a parameter multiple is congruent, +modulo a two-block sum, to a parameter multiple whose cofactor is already over +the maximal ideal, then its own cofactor is over the maximal ideal. -/ +theorem parameterFactor_mem_maximalIdeal_of_eq_parameter_add_sum_products + [Nontrivial G] + (D : RightSquareZeroTraceData k R B N G) + (m : Ideal R) (n : ℕ) + {z w : B} {iota : Type*} (s : Finset iota) + (hpow : m ^ n ≤ Module.annihilator R G) + (hw : D.pi w ∈ 𝔪) + (a b : iota → B) + (ha : ∀ i ∈ s, D.pi (a i) ∈ m ^ n) + (hb : ∀ i ∈ s, D.pi (b i) ∈ m ^ n) + (heq : D.c * z = D.c * w + ∑ i ∈ s, a i * b i) : + D.pi z ∈ 𝔪 := by + have hsep : D.pi (z - w) ∈ 𝔪 := by + apply parameterFactor_mem_maximalIdeal_of_eq_sum_products + D m n s hpow a b ha hb + calc + D.c * (z - w) = D.c * z - D.c * w := mul_sub _ _ _ + _ = ∑ i ∈ s, a i * b i := by rw [heq]; abel + have hsum : D.pi (z - w) + D.pi w ∈ 𝔪 := + (IsLocalRing.maximalIdeal R).add_mem hsep hw + simpa using hsum + +/-- Finite length supplies one exponent for both the two-block vanishing and +the parameter-ideal separation theorem. -/ +theorem exists_highPower_parameterIdeal_reduction + [Nontrivial G] + (D : RightSquareZeroTraceData k R B N G) + (hG : IsFiniteLength R G) : + ∃ n : ℕ, + 𝔪 ^ n ≤ Module.annihilator R G ∧ + ∀ {z w : B} {iota : Type*} (s : Finset iota), + D.pi w ∈ 𝔪 → + ∀ (a b : iota → B), + (∀ i ∈ s, D.pi (a i) ∈ 𝔪 ^ n) → + (∀ i ∈ s, D.pi (b i) ∈ 𝔪 ^ n) → + D.c * z = D.c * w + ∑ i ∈ s, a i * b i → + D.pi z ∈ 𝔪 := by + obtain ⟨n, hpow⟩ := + exists_maximalIdeal_pow_le_annihilator_of_finiteLength hG + refine ⟨n, hpow, ?_⟩ + intro z w iota s hw a b ha hb heq + exact parameterFactor_mem_maximalIdeal_of_eq_parameter_add_sum_products + D 𝔪 n s hpow hw a b ha hb heq + + +end + +end Stafford38.Characteristic.SquareZeroHighPowerReduction diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLinearTrace.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLinearTrace.lean new file mode 100644 index 0000000000..fd6b3bc7d6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLinearTrace.lean @@ -0,0 +1,225 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Trace +import Mathlib.LinearAlgebra.Projection + +/-! +# The square-zero linear trace calculation + +This file isolates the finite-dimensional block calculation used in the local +trace argument. Composition is written in Lean's order: +`F.comp G` sends `v` to `F (G v)`. Thus the commutator hypothesis below is + +`A.comp B - B.comp A = C.comp Z`. + +If `ker C = range C`, then `C` identifies `V / range C` with `range C`. +Choosing a linear section of the quotient map gives the usual two-by-two +block decomposition. The off-diagonal block of the displayed commutator is +a sum of two rectangular commutators, so its trace is zero. +-/ + +noncomputable section + +namespace Stafford38.Characteristic.SquareZeroLinearTrace + +open Function + +variable {k V : Type*} [Field k] [AddCommGroup V] [Module k V] + +/-- An endomorphism commuting with `C` preserves `range C`. -/ +lemma mapsTo_range_of_comp_comm (C F : V →ₗ[k] V) + (hF : F.comp C = C.comp F) : Set.MapsTo F (LinearMap.range C) (LinearMap.range C) := by + rintro _ ⟨v, rfl⟩ + refine ⟨F v, ?_⟩ + exact LinearMap.congr_fun hF.symm v + +/-- The endomorphism induced by `F` on `V / range C`. -/ +def quotientEnd (C F : V →ₗ[k] V) (hF : F.comp C = C.comp F) : + (V ⧸ LinearMap.range C) →ₗ[k] (V ⧸ LinearMap.range C) := + (LinearMap.range C).mapQ (LinearMap.range C) F + (mapsTo_range_of_comp_comm C F hF) + +/-- The restriction of a commuting endomorphism to `range C`. -/ +def rangeEnd (C F : V →ₗ[k] V) (hF : F.comp C = C.comp F) : + LinearMap.range C →ₗ[k] LinearMap.range C := + F.restrict (mapsTo_range_of_comp_comm C F hF) + +/-- Exactness makes the map induced by `C` from the quotient to its range an equivalence. -/ +def quotientToRangeEquiv (C : V →ₗ[k] V) (hExact : LinearMap.ker C = LinearMap.range C) : + (V ⧸ LinearMap.range C) ≃ₗ[k] LinearMap.range C := by + let cbar : (V ⧸ LinearMap.range C) →ₗ[k] LinearMap.range C := + (LinearMap.range C).liftQ C.rangeRestrict (by + intro x hx + rw [LinearMap.mem_ker] + apply Subtype.ext + exact LinearMap.mem_ker.mp (hExact ▸ hx)) + refine LinearEquiv.ofBijective cbar ⟨?_, ?_⟩ + · intro q₁ q₂ hq + obtain ⟨x, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) q₁ + obtain ⟨y, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) q₂ + apply (Submodule.Quotient.eq (LinearMap.range C)).mpr + rw [← hExact, LinearMap.mem_ker] + rw [map_sub, sub_eq_zero] + simpa [cbar] using Subtype.ext_iff.mp hq + · intro y + obtain ⟨x, hx⟩ := y.property + refine ⟨Submodule.Quotient.mk x, ?_⟩ + exact Subtype.ext hx + +@[simp] +lemma quotientToRangeEquiv_apply_mk (C : V →ₗ[k] V) + (hExact : LinearMap.ker C = LinearMap.range C) (v : V) : + quotientToRangeEquiv C hExact (Submodule.Quotient.mk v) = C.rangeRestrict v := rfl + +private lemma trace_commutator_sum_eq_zero + {W : Type*} [AddCommGroup W] [Module k W] [FiniteDimensional k W] + (P Q X Y : W →ₗ[k] W) : + LinearMap.trace k W + (P.comp Y - Y.comp P + (X.comp Q - Q.comp X)) = 0 := by + simp only [map_add, map_sub] + rw [LinearMap.trace_comp_comm' P Y, LinearMap.trace_comp_comm' X Q] + abel + +/-- The upper-right block of a commuting endomorphism relative to a section of +the quotient by `range C`. -/ +def offDiagonal (C F : V →ₗ[k] V) (hF : F.comp C = C.comp F) + (s : (V ⧸ LinearMap.range C) →ₗ[k] V) + (hs : (LinearMap.range C).mkQ.comp s = LinearMap.id) : + (V ⧸ LinearMap.range C) →ₗ[k] LinearMap.range C := + (F.comp s - s.comp (quotientEnd C F hF)).codRestrict (LinearMap.range C) (by + intro x + have hz : + (LinearMap.range C).mkQ + ((F.comp s - s.comp (quotientEnd C F hF)) x) = 0 := by + change (LinearMap.range C).mkQ + (F (s x) - s (quotientEnd C F hF x)) = 0 + rw [map_sub] + have hsx : (LinearMap.range C).mkQ (s x) = x := by + exact LinearMap.congr_fun hs x + have hsFx : + (LinearMap.range C).mkQ (s (quotientEnd C F hF x)) = quotientEnd C F hF x := by + exact LinearMap.congr_fun hs (quotientEnd C F hF x) + have hFq : + (LinearMap.range C).mkQ (F (s x)) = quotientEnd C F hF x := by + calc + (LinearMap.range C).mkQ (F (s x)) = + quotientEnd C F hF ((LinearMap.range C).mkQ (s x)) := rfl + _ = quotientEnd C F hF x := congrArg (quotientEnd C F hF) hsx + rw [hFq, hsFx, sub_self] + have hxker : + (F.comp s - s.comp (quotientEnd C F hF)) x ∈ + LinearMap.ker (LinearMap.range C).mkQ := LinearMap.mem_ker.mpr hz + simpa only [Submodule.ker_mkQ] using hxker) + +/-- The exact square-zero trace lemma. Exactness itself implies `C² = 0`, +so neither a separate square-zero hypothesis nor a characteristic assumption +is needed for this linear calculation. -/ +theorem quotientEnd_trace_eq_zero + [FiniteDimensional k V] + (C A B Z : V →ₗ[k] V) + (hExact : LinearMap.ker C = LinearMap.range C) + (hAC : A.comp C = C.comp A) + (hBC : B.comp C = C.comp B) + (hZC : Z.comp C = C.comp Z) + (hcomm : A.comp B - B.comp A = C.comp Z) : + LinearMap.trace k (V ⧸ LinearMap.range C) (quotientEnd C Z hZC) = 0 := by + let q : V →ₗ[k] (V ⧸ LinearMap.range C) := (LinearMap.range C).mkQ + obtain ⟨s, hs⟩ := q.exists_rightInverse_of_surjective + (LinearMap.range_eq_top.mpr (Submodule.mkQ_surjective (LinearMap.range C))) + let e := quotientToRangeEquiv C hExact + let Aq := quotientEnd C A hAC + let Bq := quotientEnd C B hBC + let Zq := quotientEnd C Z hZC + let Ak := rangeEnd C A hAC + let Bk := rangeEnd C B hBC + let Au := offDiagonal C A hAC s hs + let Bu := offDiagonal C B hBC s hs + + have hs_apply (x : V ⧸ LinearMap.range C) : q (s x) = x := by + exact LinearMap.congr_fun hs x + + have hquot_comm : Aq.comp Bq = Bq.comp Aq := by + apply LinearMap.ext + intro x + obtain ⟨v, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) x + apply (Submodule.Quotient.eq (LinearMap.range C)).mpr + change A (B v) - B (A v) ∈ LinearMap.range C + refine ⟨Z v, ?_⟩ + exact (LinearMap.congr_fun hcomm v).symm + + have heA : e.toLinearMap.comp Aq = Ak.comp e.toLinearMap := by + apply LinearMap.ext + intro x + obtain ⟨v, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) x + apply Subtype.ext + exact LinearMap.congr_fun hAC.symm v + + have heB : e.toLinearMap.comp Bq = Bk.comp e.toLinearMap := by + apply LinearMap.ext + intro x + obtain ⟨v, rfl⟩ := Submodule.mkQ_surjective (LinearMap.range C) x + apply Subtype.ext + exact LinearMap.congr_fun hBC.symm v + + have hblock : + e.toLinearMap.comp Zq = + Ak.comp Bu + Au.comp Bq - Bk.comp Au - Bu.comp Aq := by + apply LinearMap.ext + intro x + apply Subtype.ext + have hABx : Aq (Bq x) = Bq (Aq x) := LinearMap.congr_fun hquot_comm x + have hleft : e (Zq x) = C.rangeRestrict (Z (s x)) := by + calc + e (Zq x) = e (Zq (q (s x))) := by rw [hs_apply x] + _ = C.rangeRestrict (Z (s x)) := rfl + change (e (Zq x) : V) = _ + rw [hleft] + dsimp [Ak, Bk, Au, Bu, rangeEnd, offDiagonal] + change C (Z (s x)) = + A (B (s x) - s (Bq x)) + + (A (s (Bq x)) - s (Aq (Bq x))) - + B (A (s x) - s (Aq x)) - + (B (s (Aq x)) - s (Bq (Aq x))) + have hh := LinearMap.congr_fun hcomm (s x) + simp only [LinearMap.sub_apply, LinearMap.comp_apply] at hh + rw [← hh] + simp only [LinearMap.sub_apply, LinearMap.comp_apply, map_sub] + rw [hABx] + abel + + let X : (V ⧸ LinearMap.range C) →ₗ[k] (V ⧸ LinearMap.range C) := + e.symm.toLinearMap.comp Au + let Y : (V ⧸ LinearMap.range C) →ₗ[k] (V ⧸ LinearMap.range C) := + e.symm.toLinearMap.comp Bu + + have hZblock : Zq = Aq.comp Y - Y.comp Aq + (X.comp Bq - Bq.comp X) := by + apply LinearMap.ext + intro x + apply e.injective + have hb := LinearMap.congr_fun hblock x + simp only [LinearMap.comp_apply, LinearMap.add_apply, LinearMap.sub_apply] at hb ⊢ + have hY (u : V ⧸ LinearMap.range C) : e (Y u) = Bu u := by + exact e.apply_symm_apply (Bu u) + have hX (u : V ⧸ LinearMap.range C) : e (X u) = Au u := by + exact e.apply_symm_apply (Au u) + have hAY : e (Aq (Y x)) = Ak (Bu x) := by + calc + e (Aq (Y x)) = Ak (e (Y x)) := LinearMap.congr_fun heA (Y x) + _ = Ak (Bu x) := congrArg Ak (hY x) + have hBX : e (Bq (X x)) = Bk (Au x) := by + calc + e (Bq (X x)) = Bk (e (X x)) := LinearMap.congr_fun heB (X x) + _ = Bk (Au x) := congrArg Bk (hX x) + rw [map_add, map_sub, map_sub, hAY, hY, hX, hBX] + exact hb.trans (by abel) + + change LinearMap.trace k (V ⧸ LinearMap.range C) Zq = 0 + rw [hZblock] + exact trace_commutator_sum_eq_zero Aq Bq X Y + + +end Stafford38.Characteristic.SquareZeroLinearTrace diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedExactness.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedExactness.lean new file mode 100644 index 0000000000..0104d6a174 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedExactness.lean @@ -0,0 +1,446 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.ConcreteSquareZeroTraceData +import LeanPool.Stafford38.Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroOreLocalization +import Mathlib.Algebra.Module.LocalizedModule.Basic +import Mathlib.GroupTheory.QuotientGroup.Basic +import Mathlib.RingTheory.OreLocalization.Ring + +/-! +# Localization preserves the square-zero deformation sequence + +Mathlib constructs the localization of a left module over a left Ore set as +`OreLocalization S N`. Applied to the opposite deformation ring, this is the +localization of the original right module. This file proves directly on Ore +fractions that the square-zero parameter remains exact. It also constructs +the specialization map to the ordinary commutative localization of the +special fibre and proves that its kernel is the same parameter image. + +The results are not conditional localized-exactness interfaces: the localized +module, parameter action, and specialization map are concrete constructions. +The only typeclass parameter is Mathlib's `OreSet`; its existence for the +pulled-back denominators is proved in `SquareZeroOreLocalization`. +-/ + +namespace Stafford38.Characteristic.SquareZeroLocalizedExactness + +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.Characteristic.SquareZeroOreLocalization + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) + +/-- Denominators in the opposite deformation ring lying over `S`. -/ +abbrev OppositeDenominators (S : Submonoid R) : Submonoid Bᵐᵒᵖ := + S.comap (oppositeSpecializationMonoidHom D) + +/-- The concrete localized opposite-ring module supplied by Mathlib's Ore +localization construction. -/ +abbrev LocalizedDeformationModule (S : Submonoid R) + [OreLocalization.OreSet (OppositeDenominators D S)] := + OreLocalization (OppositeDenominators D S) N + +/-- A pulled-back Ore denominator specializes to a denominator in `S`. -/ +def denominatorMap (S : Submonoid R) : + OppositeDenominators D S →* S where + toFun s := ⟨oppositeSpecializationMonoidHom D s, s.property⟩ + map_one' := by ext; simp + map_mul' a b := by ext; simp + +section Ore + +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] + +/-- Action of the square-zero parameter on the localized module. It is the +original opposite-ring action, extended by the Ore localization module +construction. -/ +def localizedCAct : + LocalizedDeformationModule D S →+ LocalizedDeformationModule D S where + toFun x := MulOpposite.op D.c • x + map_zero' := smul_zero _ + map_add' x y := smul_add _ x y + +@[simp] theorem localizedCAct_apply + (x : LocalizedDeformationModule D S) : + localizedCAct D S x = MulOpposite.op D.c • x := + rfl + +/-- On a displayed Ore fraction, the localized parameter acts on its +numerator without changing its denominator. -/ +theorem localizedCAct_oreDiv + (m : N) (s : OppositeDenominators D S) : + localizedCAct D S (m /ₒ s) = + (MulOpposite.op D.c • m) /ₒ s := by + change MulOpposite.op D.c • (m /ₒ s) = _ + rw [← OreLocalization.oreDiv_one_smul] + simpa using OreLocalization.oreDiv_smul_char + (MulOpposite.op D.c) m 1 s (MulOpposite.op D.c) s + (show (s : Bᵐᵒᵖ) * MulOpposite.op D.c = + MulOpposite.op D.c * s from by + apply MulOpposite.unop_injective + exact D.c_center.comm s.val.unop) + +/-- The localized parameter still squares to zero. -/ +theorem localizedCAct_sq_eq_zero + (x : LocalizedDeformationModule D S) : + localizedCAct D S (localizedCAct D S x) = 0 := by + change MulOpposite.op D.c • (MulOpposite.op D.c • x) = 0 + rw [← mul_smul] + have hc : MulOpposite.op D.c * MulOpposite.op D.c = 0 := by + apply MulOpposite.unop_injective + simpa [pow_two] using D.c_sq + rw [hc, zero_smul] + +/-- Ore localization preserves the exact square-zero parameter sequence: +the kernel of multiplication by `c` remains its image. -/ +theorem localizedCAct_ker_eq_range : + AddMonoidHom.ker (localizedCAct D S) = + AddMonoidHom.range (localizedCAct D S) := by + apply le_antisymm + · intro x hx + induction x using OreLocalization.ind with + | _ m s => + rw [AddMonoidHom.mem_ker, localizedCAct_oreDiv] at hx + have hfrac : (MulOpposite.op D.c • m) /ₒ s = + (0 : N) /ₒ (1 : OppositeDenominators D S) := by + simpa using hx + obtain ⟨u, v, hv, huv⟩ := + OreLocalization.oreDiv_eq_iff.mp hfrac + have hvc : v • (MulOpposite.op D.c • m) = 0 := by + simpa using hv.symm + have hcm : MulOpposite.op D.c • (v • m) = 0 := by + rw [← mul_smul] + rw [show MulOpposite.op D.c * v = v * MulOpposite.op D.c by + apply MulOpposite.unop_injective + exact (D.c_center.comm v.unop).symm] + simpa [mul_smul] using hvc + have hker : v • m ∈ LinearMap.ker D.cAct := by + rw [LinearMap.mem_ker, D.cAct_apply] + exact hcm + rw [D.c_exact] at hker + obtain ⟨q, hq⟩ := hker + have hq' : MulOpposite.op D.c • q = v • m := by + simpa [D.cAct_apply] using hq + have hvs : v * (s : Bᵐᵒᵖ) ∈ OppositeDenominators D S := by + rw [← huv] + have hu1 : (u : Bᵐᵒᵖ) * + ((1 : OppositeDenominators D S) : Bᵐᵒᵖ) = u := by simp + rw [hu1] + exact u.property + let t : OppositeDenominators D S := ⟨v * s, hvs⟩ + refine ⟨q /ₒ t, ?_⟩ + rw [localizedCAct_oreDiv, hq'] + calc + (v • m) /ₒ t = m /ₒ s := by + symm + exact OreLocalization.expand m s v hvs + _ = m /ₒ s := rfl + · intro x hx + obtain ⟨y, rfl⟩ := hx + rw [AddMonoidHom.mem_ker] + exact localizedCAct_sq_eq_zero D S y + +/-- Specialization of an Ore-localized deformation fraction to the ordinary +commutative localization of the special fibre. -/ +def localizedSpecializationFun : + LocalizedDeformationModule D S → LocalizedModule S G := + OreLocalization.liftExpand + (fun m s => LocalizedModule.mk (D.rho m) (denominatorMap D S s)) + (by + intro m t s hts + apply LocalizedModule.mk_eq.mpr + refine ⟨1, ?_⟩ + simp only [one_smul] + have hrho : D.rho (t • m) = D.pi t.unop • D.rho m := by + simpa using D.rho_action t.unop m + rw [hrho] + change + (oppositeSpecializationMonoidHom D + (⟨t * s, hts⟩ : OppositeDenominators D S)) • D.rho m = + (denominatorMap D S s : R) • + (D.pi t.unop • D.rho m) + simp only [map_mul, MulOpposite.unop_mul] + rw [mul_smul] + change D.pi t.unop • D.pi s.val.unop • D.rho m = + D.pi s.val.unop • D.pi t.unop • D.rho m + rw [smul_comm]) + +@[simp] theorem localizedSpecializationFun_oreDiv + (m : N) (s : OppositeDenominators D S) : + localizedSpecializationFun D S (m /ₒ s) = + LocalizedModule.mk (D.rho m) (denominatorMap D S s) := + rfl + +/-- The localized specialization is an additive homomorphism. -/ +def localizedSpecialization : + LocalizedDeformationModule D S →+ LocalizedModule S G where + toFun := localizedSpecializationFun D S + map_zero' := by + change localizedSpecializationFun D S 0 = 0 + rw [← OreLocalization.zero_oreDiv + (1 : OppositeDenominators D S)] + rw [localizedSpecializationFun_oreDiv] + simp + map_add' x y := by + induction x using OreLocalization.ind with + | _ m s => + induction y using OreLocalization.ind with + | _ n t => + rw [OreLocalization.oreDiv_add_oreDiv] + simp only [localizedSpecializationFun_oreDiv] + rw [LocalizedModule.mk_add_mk] + apply LocalizedModule.mk_eq.mpr + refine ⟨1, ?_⟩ + simp only [one_smul] + rw [map_add] + have hm : D.rho (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t • m) = + D.pi (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t).val.unop • + D.rho m := by + have h := D.rho_action + (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t).val.unop m + rwa [MulOpposite.op_unop] at h + have hn : D.rho (OreLocalization.oreNum (s : Bᵐᵒᵖ) t • n) = + D.pi (OreLocalization.oreNum (s : Bᵐᵒᵖ) t).unop • + D.rho n := by + simpa using D.rho_action + (OreLocalization.oreNum (s : Bᵐᵒᵖ) t).unop n + rw [hm, hn] + have hore := OreLocalization.ore_eq (s : Bᵐᵒᵖ) t + have hab := congrArg (oppositeSpecializationMonoidHom D) hore + simp only [map_mul] at hab ⊢ + have hab' : + (denominatorMap D S + (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t) : R) * + (denominatorMap D S s : R) = + D.pi (OreLocalization.oreNum (s : Bᵐᵒᵖ) t).unop * + (denominatorMap D S t : R) := by + exact hab + simp only [smul_add, Submonoid.smul_def, Submonoid.coe_mul, + ← mul_smul] + congr 1 + · congr 1 + rw [show D.pi + (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t).val.unop = + (denominatorMap D S + (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t) : R) from rfl] + ring + · congr 1 + calc + (denominatorMap D S s : R) * + (denominatorMap D S t : R) * + D.pi (OreLocalization.oreNum (s : Bᵐᵒᵖ) t).unop = + (D.pi (OreLocalization.oreNum (s : Bᵐᵒᵖ) t).unop * + (denominatorMap D S t : R)) * + (denominatorMap D S s : R) := by ring + _ = ((denominatorMap D S + (OreLocalization.oreDenom (s : Bᵐᵒᵖ) t) : R) * + (denominatorMap D S s : R)) * + (denominatorMap D S s : R) := by rw [← hab'] + +@[simp] theorem localizedSpecialization_apply + (x : LocalizedDeformationModule D S) : + localizedSpecialization D S x = localizedSpecializationFun D S x := + rfl + +/-- Specialization remains surjective after localization. A commutative +denominator is lifted through the surjective deformation specialization. -/ +theorem localizedSpecialization_surjective : + Function.Surjective (localizedSpecialization D S) := by + intro y + induction y using LocalizedModule.induction_on with + | _ g s => + obtain ⟨m, hm⟩ := D.rho_surjective g + obtain ⟨b, hb⟩ := D.pi_surjective (s : R) + have hbS : oppositeSpecializationMonoidHom D (MulOpposite.op b) ∈ S := by + change D.pi b ∈ S + rw [hb] + exact s.property + let t : OppositeDenominators D S := ⟨MulOpposite.op b, hbS⟩ + have hden : denominatorMap D S t = s := by + apply Subtype.ext + exact hb + refine ⟨m /ₒ t, ?_⟩ + rw [localizedSpecialization_apply, + localizedSpecializationFun_oreDiv, hm, hden] + +/-- The localized specialization kills the localized parameter image. -/ +theorem localizedSpecialization_localizedCAct_eq_zero + (x : LocalizedDeformationModule D S) : + localizedSpecialization D S (localizedCAct D S x) = 0 := by + induction x using OreLocalization.ind with + | _ m s => + rw [localizedCAct_oreDiv, localizedSpecialization_apply, + localizedSpecializationFun_oreDiv] + have hrho : D.rho (MulOpposite.op D.c • m) = 0 := by + rw [D.rho_action, D.pi_c, zero_smul] + rw [hrho, LocalizedModule.zero_mk] + +/-- The specialization kernel after Ore localization is exactly the image of +the localized square-zero parameter. -/ +theorem localizedSpecialization_ker_eq_range : + AddMonoidHom.ker (localizedSpecialization D S) = + AddMonoidHom.range (localizedCAct D S) := by + apply le_antisymm + · intro x hx + induction x using OreLocalization.ind with + | _ m s => + rw [AddMonoidHom.mem_ker, localizedSpecialization_apply, + localizedSpecializationFun_oreDiv] at hx + have hzero : + LocalizedModule.mk (D.rho m) (denominatorMap D S s) = + LocalizedModule.mk (0 : G) (1 : S) := by + simpa using hx + obtain ⟨u, hu⟩ := LocalizedModule.mk_eq.mp hzero + have hurho' : u • D.rho m = 0 := by + simpa using hu + have hurho : (u : R) • D.rho m = 0 := hurho' + obtain ⟨b, hb⟩ := D.pi_surjective (u : R) + let v : Bᵐᵒᵖ := MulOpposite.op b + have hvrho : D.rho (v • m) = 0 := by + have h := D.rho_action b m + change D.rho (v • m) = D.pi b • D.rho m at h + rw [h, hb] + exact hurho + have hvker : v • m ∈ LinearMap.ker D.rho := by + exact LinearMap.mem_ker.mpr hvrho + rw [D.rho_ker] at hvker + obtain ⟨q, hq⟩ := hvker + have hq' : MulOpposite.op D.c • q = v • m := by + simpa [D.cAct_apply] using hq + have hvS : v ∈ OppositeDenominators D S := by + change D.pi b ∈ S + rw [hb] + exact u.property + have hvs : v * (s : Bᵐᵒᵖ) ∈ OppositeDenominators D S := + mul_mem hvS s.property + let t : OppositeDenominators D S := ⟨v * s, hvs⟩ + refine ⟨q /ₒ t, ?_⟩ + rw [localizedCAct_oreDiv, hq'] + symm + exact OreLocalization.expand m s v hvs + · intro x hx + obtain ⟨y, rfl⟩ := hx + rw [AddMonoidHom.mem_ker] + exact localizedSpecialization_localizedCAct_eq_zero D S y + +/-- Quotienting the localized deformation module by the parameter image gives +the ordinary commutative localization of the special fibre. -/ +noncomputable def localizedSpecialFibreAddEquiv : + (LocalizedDeformationModule D S ⧸ + AddMonoidHom.range (localizedCAct D S)) ≃+ + LocalizedModule S G := + (QuotientAddGroup.quotientAddEquivOfEq + (localizedSpecialization_ker_eq_range D S).symm).trans + (QuotientAddGroup.quotientKerEquivOfSurjective + (localizedSpecialization D S) + (localizedSpecialization_surjective D S)) + +/-- The complete localized exactness package needed by the local trace +argument: both parameter exactness and specialization exactness hold, and the +specialization is onto the ordinary localized special fibre. -/ +theorem localized_squareZero_exactness : + AddMonoidHom.ker (localizedCAct D S) = + AddMonoidHom.range (localizedCAct D S) ∧ + Function.Surjective (localizedSpecialization D S) ∧ + AddMonoidHom.ker (localizedSpecialization D S) = + AddMonoidHom.range (localizedCAct D S) := + ⟨localizedCAct_ker_eq_range D S, + localizedSpecialization_surjective D S, + localizedSpecialization_ker_eq_range D S⟩ + + +end Ore + +/-- Exactness for one explicit choice of Mathlib's pulled-back Ore-set +structure. This packages only already constructed maps and equations. -/ +def LocalizedExactnessFor (S : Submonoid R) + (h : OreLocalization.OreSet (OppositeDenominators D S)) : Prop := + letI := h + AddMonoidHom.ker (localizedCAct D S) = + AddMonoidHom.range (localizedCAct D S) ∧ + Function.Surjective (localizedSpecialization D S) ∧ + AddMonoidHom.ker (localizedSpecialization D S) = + AddMonoidHom.range (localizedCAct D S) + +/-- The Ore-set existence theorem and the fraction-level exactness proof +together produce a genuine localized deformation sequence for every +multiplicative set in the special fibre. -/ +theorem exists_localizedExactnessFor (S : Submonoid R) : + ∃ h : OreLocalization.OreSet (OppositeDenominators D S), + LocalizedExactnessFor D S h := by + obtain ⟨h⟩ := nonempty_oreSet_comap_op D S + refine ⟨h, ?_⟩ + letI := h + exact localized_squareZero_exactness D S + +/-- At a minimal prime over the special-fibre annihilator, the localized +deformation exact sequence exists and its commutative special fibre is +simultaneously nonzero and of finite length. -/ +theorem exists_minimalPrimeLocalizedExactnessAndFiniteLength + [IsNoetherianRing R] [Module.Finite R G] + (P : Ideal R) [P.IsPrime] + (hP : P ∈ (Module.annihilator R G).minimalPrimes) : + ∃ h : OreLocalization.OreSet + (OppositeDenominators D P.primeCompl), + LocalizedExactnessFor D P.primeCompl h ∧ + Nontrivial (LocalizedModule P.primeCompl G) ∧ + IsFiniteLength (Localization P.primeCompl) + (LocalizedModule P.primeCompl G) := by + obtain ⟨h, hexact⟩ := exists_localizedExactnessFor D P.primeCompl + refine ⟨h, hexact, ?_⟩ + exact Stafford38.Characteristic.MinimalPrimeFiniteLengthLocalization.localizedModule_nontrivial_and_isFiniteLength + P hP + + +end + +end Stafford38.Characteristic.SquareZeroLocalizedExactness + +namespace Stafford38.CharacteristicConcreteSquareZeroTraceData + +open Stafford38.Characteristic.SquareZeroLocalizedExactness +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The concrete filtered Weyl two-jet admits a localized exact deformation +sequence at every prime of its commutative symbol ring. -/ +theorem exists_primeLocalizedExactness + (I : RightIdeal (PresentedWeyl k n)) + (P : Ideal (Stafford38.Characteristic.SymbolRing k n)) [P.IsPrime] : + ∃ h : OreLocalization.OreSet + (OppositeDenominators (filteredQuotientTwoJetTraceData k I) + P.primeCompl), + LocalizedExactnessFor (filteredQuotientTwoJetTraceData k I) + P.primeCompl h := + exists_localizedExactnessFor + (filteredQuotientTwoJetTraceData k I) P.primeCompl + + +end + + +end Stafford38.CharacteristicConcreteSquareZeroTraceData diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedRing.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedRing.lean new file mode 100644 index 0000000000..063eea9ecc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroLocalizedRing.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroLocalizedExactness +import Mathlib.RingTheory.Localization.Basic + +/-! +# The localized deformation-ring specialization + +The module localization used by the right Rees two-jet is over the opposite +deformation ring. This file constructs the corresponding ring map from that +Ore localization to the ordinary commutative localization of the special +fibre. It is the first ring-level input in the Artinian-local Gabber route. + +No assertion is made that the kernel is generated by the square-zero +parameter, that the target is an Artinian quotient, or that a coefficient +field exists. +-/ + +namespace Stafford38.Characteristic.SquareZeroLocalizedRing + +open Stafford38.Characteristic.SquareZeroTraceData +open Stafford38.Characteristic.SquareZeroOreLocalization +open Stafford38.Characteristic.SquareZeroLocalizedExactness + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) + +/-- Specialization is a ring homomorphism on the opposite deformation ring +because its target is commutative. -/ +def oppositeSpecializationRingHom : Bᵐᵒᵖ →+* R where + toFun b := D.pi b.unop + map_one' := by simp + map_zero' := by simp + map_add' a b := by simp + map_mul' a b := by + change D.pi (b.unop * a.unop) = D.pi a.unop * D.pi b.unop + rw [map_mul, mul_comm] + +@[simp] theorem oppositeSpecializationRingHom_apply (b : Bᵐᵒᵖ) : + oppositeSpecializationRingHom D b = D.pi b.unop := + rfl + +section Ore + +variable (S : Submonoid R) +variable [OreLocalization.OreSet (OppositeDenominators D S)] + +/-- The canonical numerator units in a commutative localization. -/ +def localizationNumeratorUnits : S →* Units (Localization S) where + toFun := OreLocalization.numeratorUnit + map_one' := by + apply Units.ext + change (OreLocalization.numeratorHom : R →* Localization S) 1 = 1 + exact map_one _ + map_mul' a b := by + apply Units.ext + change (OreLocalization.numeratorHom : R →* Localization S) + ((a : R) * (b : R)) = + (OreLocalization.numeratorHom : R →* Localization S) a * + (OreLocalization.numeratorHom : R →* Localization S) b + exact map_mul _ _ _ + +/-- Every pulled-back Ore denominator maps to its canonical numerator unit in +the commutative localization. -/ +def localizedDenominatorUnits : + OppositeDenominators D S →* Units (Localization S) := + (localizationNumeratorUnits S).comp (denominatorMap D S) + +@[simp] theorem localizedDenominatorUnits_val + (s : OppositeDenominators D S) : + (localizedDenominatorUnits D S s : Localization S) = + algebraMap R (Localization S) (denominatorMap D S s) := by + rfl + +/-- The specialization of the opposite deformation ring extends through its +Ore localization to the ordinary localization of the commutative fibre. -/ +def localizedOppositeSpecialization : + OreLocalization (OppositeDenominators D S) (Bᵐᵒᵖ) →+* Localization S := + OreLocalization.universalHom + ((algebraMap R (Localization S)).comp + (oppositeSpecializationRingHom D)) + (localizedDenominatorUnits D S) + (fun s => by + rw [localizedDenominatorUnits_val] + rfl) + +@[simp] theorem localizedOppositeSpecialization_oreDiv + (b : Bᵐᵒᵖ) (s : OppositeDenominators D S) : + localizedOppositeSpecialization D S (b /ₒ s) = + ((localizedDenominatorUnits D S s)⁻¹ : Units (Localization S)) * + algebraMap R (Localization S) (D.pi b.unop) := + rfl + +@[simp] theorem localizedOppositeSpecialization_numerator (b : Bᵐᵒᵖ) : + localizedOppositeSpecialization D S + (OreLocalization.numeratorHom b) = + algebraMap R (Localization S) (D.pi b.unop) := by + exact OreLocalization.universalHom_commutes _ _ _ + +@[simp] theorem localizedOppositeSpecialization_parameter : + localizedOppositeSpecialization D S + (OreLocalization.numeratorHom (MulOpposite.op D.c)) = 0 := by + simp [D.pi_c] + +/-- Surjectivity of the original specialization survives localization. This +is a ring-level statement; it does not identify the kernel. -/ +theorem localizedOppositeSpecialization_surjective : + Function.Surjective (localizedOppositeSpecialization D S) := by + intro z + refine Localization.induction_on z ?_ + rintro ⟨r, s⟩ + obtain ⟨a, ha⟩ := D.pi_surjective r + obtain ⟨b, hb⟩ := D.pi_surjective (s : R) + let sb : OppositeDenominators D S := + ⟨MulOpposite.op b, by + change D.pi b ∈ S + rw [hb] + exact s.property⟩ + refine ⟨(MulOpposite.op a) /ₒ sb, ?_⟩ + rw [localizedOppositeSpecialization_oreDiv] + change + ((OreLocalization.numeratorUnit (denominatorMap D S sb))⁻¹ : + Units (Localization S)) * + algebraMap R (Localization S) (D.pi a) = + Localization.mk r s + rw [ha] + change (1 /ₒ denominatorMap D S sb) * (r /ₒ 1) = r /ₒ s + rw [OreLocalization.mul_div_one] + have hs : denominatorMap D S sb = s := Subtype.ext hb + rw [hs] + simp + +end Ore + + +end + + +end Stafford38.Characteristic.SquareZeroLocalizedRing diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroOreLocalization.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroOreLocalization.lean new file mode 100644 index 0000000000..7002ea35f8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroOreLocalization.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SquareZeroTraceData +import Mathlib.RingTheory.OreLocalization.OreSet + +/-! +# Ore localization of a square-zero deformation + +For a ring with a central square-zero parameter, whose commutators are +divisible by that parameter, the inverse image of every multiplicative set in +the commutative special fibre is a left Ore set. Squaring the denominator is +enough both for the Ore equation and for the weak cancellation axiom. + +This is the localization input needed by the minimal-prime trace argument. No +trace, finite-length, or prime-ideal conclusion is asserted here. +-/ + +namespace Stafford38.Characteristic.SquareZeroOreLocalization + +open Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable {k : Type u_k} {R : Type u_R} {B : Type u_B} +variable {N : Type u_N} {G : Type u_G} +variable [Field k] [CommRing R] [Algebra k R] +variable [Ring B] [Algebra k B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] +variable [AddCommGroup G] [Module k G] [Module R G] + +variable (D : RightSquareZeroTraceData k R B N G) + +/-- Multiplication by `c` kills the failure of two elements of `B` to +commute. -/ +theorem c_mul_commutator_eq_zero (a b : B) : + D.c * Stafford.commutator a b = 0 := by + obtain ⟨z, hz, -⟩ := D.commutator_factor a b + rw [hz, ← mul_assoc, ← pow_two, D.c_sq, zero_mul] + +/-- Moving a factor past another factor is legitimate after multiplying by +the square-zero parameter. -/ +theorem c_mul_mul_comm (a b : B) : D.c * (a * b) = D.c * (b * a) := by + have h := c_mul_commutator_eq_zero D a b + simp only [Stafford.commutator_eq_shared, AlgebraicAnalysis.ringCommutator, + mul_sub] at h + exact sub_eq_zero.mp h + +private theorem nonempty_oreSet_comap_of + {A C : Type*} [Ring A] [CommMonoid C] + (c : A) + (cCenter : c ∈ Set.center A) + (commutatorFactor : ∀ a b : A, ∃ z : A, + Stafford.commutator a b = c * z) + (cMulComm : ∀ a b : A, c * (a * b) = c * (b * a)) + (pi : A →* C) (S : Submonoid C) : + Nonempty (OreLocalization.OreSet (S.comap pi)) := by + rw [OreLocalization.nonempty_oreSet_iff] + constructor + · intro r₁ r₂ s hrs + let delta : A := r₁ - r₂ + obtain ⟨z, hsz⟩ := commutatorFactor (s : A) delta + let s2 : S.comap pi := + ⟨(s : A) ^ 2, by + change pi ((s : A) ^ 2) ∈ S + rw [map_pow] + exact S.pow_mem s.property 2⟩ + refine ⟨s2, ?_⟩ + apply sub_eq_zero.mp + rw [← mul_sub] + change (s : A) ^ 2 * delta = 0 + have hdelta_s : delta * (s : A) = 0 := by + change (r₁ - r₂) * (s : A) = 0 + rw [sub_mul, hrs, sub_self] + have hs_delta : (s : A) * delta = c * z := by + simp only [Stafford.commutator_eq_shared, AlgebraicAnalysis.ringCommutator, + hdelta_s, sub_zero] at hsz + exact hsz + calc + (s : A) ^ 2 * delta = (s : A) * ((s : A) * delta) := by + simp [pow_two, mul_assoc] + _ = (s : A) * (c * z) := by rw [hs_delta] + _ = c * ((s : A) * z) := by + have hcs : c * (s : A) = (s : A) * c := by + exact cCenter.comm (s : A) + rw [← mul_assoc, ← hcs, mul_assoc] + _ = c * (z * (s : A)) := cMulComm (s : A) z + _ = (c * z) * (s : A) := by rw [mul_assoc] + _ = ((s : A) * delta) * (s : A) := by rw [hs_delta] + _ = (s : A) * (delta * (s : A)) := by rw [mul_assoc] + _ = 0 := by rw [hdelta_s, mul_zero] + · intro r s + obtain ⟨z, hsr⟩ := commutatorFactor (s : A) r + let s2 : S.comap pi := + ⟨(s : A) ^ 2, by + change pi ((s : A) ^ 2) ∈ S + rw [map_pow] + exact S.pow_mem s.property 2⟩ + refine ⟨(s : A) * r + c * z, s2, ?_⟩ + change (s : A) ^ 2 * r = ((s : A) * r + c * z) * (s : A) + have hmove : (s : A) * r = r * (s : A) + c * z := by + simp only [Stafford.commutator_eq_shared, AlgebraicAnalysis.ringCommutator] at hsr + simpa [add_comm] using sub_eq_iff_eq_add.mp hsr + calc + (s : A) ^ 2 * r = (s : A) * ((s : A) * r) := by + simp [pow_two, mul_assoc] + _ = (s : A) * (r * (s : A) + c * z) := by rw [hmove] + _ = ((s : A) * r) * (s : A) + (s : A) * (c * z) := by + rw [mul_add, mul_assoc] + _ = ((s : A) * r) * (s : A) + c * ((s : A) * z) := by + have hcs : c * (s : A) = (s : A) * c := by + exact cCenter.comm (s : A) + rw [← mul_assoc, ← hcs] + simp only [mul_assoc] + _ = ((s : A) * r) * (s : A) + c * (z * (s : A)) := by + rw [cMulComm (s : A) z] + _ = ((s : A) * r + c * z) * (s : A) := by + rw [add_mul] + simp only [mul_assoc] + +/-- The inverse image in `B` of a multiplicative set in the commutative fibre +is a left Ore set. The construction uses the squared denominator. + +The result is returned as `Nonempty` so callers can install the chosen Ore-set +structure locally without introducing a global instance for every `S`. -/ +theorem nonempty_oreSet_comap (S : Submonoid R) : + Nonempty (OreLocalization.OreSet (S.comap D.pi.toMonoidHom)) := + nonempty_oreSet_comap_of D.c + D.c_center + (fun a b => by + obtain ⟨z, hz, -⟩ := D.commutator_factor a b + exact ⟨z, hz⟩) + (c_mul_mul_comm D) D.pi.toMonoidHom S + +/-- Specialization from the opposite deformation ring to the commutative +special fibre. -/ +def oppositeSpecializationMonoidHom : Bᵐᵒᵖ →* R where + toFun b := D.pi b.unop + map_one' := by simp + map_mul' a b := by + change D.pi (b.unop * a.unop) = D.pi a.unop * D.pi b.unop + rw [map_mul, mul_comm] + +/-- The right-module localization uses the opposite ring. Its pulled-back +denominators are left Ore as well, so the concrete right two-jet module can be +localized by Mathlib's left Ore-localization API. -/ +theorem nonempty_oreSet_comap_op (S : Submonoid R) : + Nonempty (OreLocalization.OreSet + (S.comap (oppositeSpecializationMonoidHom D))) := by + apply nonempty_oreSet_comap_of (MulOpposite.op D.c) + · refine + { comm := ?_ + left_assoc := by intros; simp [mul_assoc] + right_assoc := by intros; simp [mul_assoc] } + intro a + apply MulOpposite.unop_injective + change a.unop * D.c = D.c * a.unop + exact (D.c_center.comm a.unop).symm + · intro a b + obtain ⟨z, hz, -⟩ := D.commutator_factor b.unop a.unop + refine ⟨MulOpposite.op z, ?_⟩ + apply MulOpposite.unop_injective + change Stafford.commutator b.unop a.unop = z * D.c + rw [hz, D.c_center.comm z] + · intro a b + apply MulOpposite.unop_injective + change b.unop * a.unop * D.c = a.unop * b.unop * D.c + rw [← D.c_center.comm (b.unop * a.unop), + ← D.c_center.comm (a.unop * b.unop)] + exact c_mul_mul_comm D b.unop a.unop + + +end + +end Stafford38.Characteristic.SquareZeroOreLocalization diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroTraceData.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroTraceData.lean new file mode 100644 index 0000000000..29825483eb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SquareZeroTraceData.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.proofs.weyl_symplectic + +/-! +# Generic square-zero trace data + +This file records the minimal algebraic interface consumed by a later trace +argument. The deformation ring may be noncommutative, and its module acts on +the right, encoded as a left action of the opposite ring. In particular, +right multiplication reverses composition of endomorphisms. + +No localization, trace theorem, minimal-prime statement, Gabber theorem, or +concrete Weyl instance is asserted here. +-/ + +namespace Stafford38.Characteristic.SquareZeroTraceData + +noncomputable section + +universe u_k u_R u_B u_N u_G + +variable (k : Type u_k) (B : Type u_B) (N : Type u_N) +variable [Field k] [Ring B] +variable [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] +variable [SMulCommClass k Bᵐᵒᵖ N] + +/-- Right multiplication by `b`, regarded as a `k`-linear endomorphism. + +The scalar action is by `Bᵐᵒᵖ`; thus `rightActionEnd k B N b` sends `m` to +`m b` in ordinary right-module notation. -/ +def rightActionEnd (b : B) : Module.End k N where + toFun m := MulOpposite.op b • m + map_add' _ _ := smul_add _ _ _ + map_smul' a m := (smul_comm a (MulOpposite.op b) m).symm + +@[simp] theorem rightActionEnd_apply (b : B) (m : N) : + rightActionEnd k B N b m = MulOpposite.op b • m := + rfl + +/-- Composition of right actions reverses the displayed endomorphism order. -/ +theorem rightActionEnd_mul_reverse (a b : B) : + rightActionEnd k B N b * rightActionEnd k B N a = + rightActionEnd k B N (a * b) := by + ext m + change MulOpposite.op b • (MulOpposite.op a • m) = + MulOpposite.op (a * b) • m + rw [← mul_smul] + rfl + +/-- The commutator of right-action endomorphisms has reversed inputs. + +With `R_b(m) = m b`, this is `[R_b,R_a] = R_[a,b]`. -/ +theorem rightAction_commutator (a b : B) : + Stafford.commutator + (rightActionEnd k B N b) (rightActionEnd k B N a) = + rightActionEnd k B N (Stafford.commutator a b) := by + simp only [Stafford.commutator_eq_shared, AlgebraicAnalysis.ringCommutator] + rw [rightActionEnd_mul_reverse, rightActionEnd_mul_reverse] + ext m + simp [rightActionEnd, AlgebraicAnalysis.ringCommutator, sub_smul] + +/-- Minimal data for a right-module square-zero deformation and its +first-order commutator bracket. + +The structure deliberately records only the interfaces required by the later +trace argument. It does not assert that such data exist for the Weyl Rees +two-jet. -/ +structure RightSquareZeroTraceData + (k : Type u_k) (R : Type u_R) (B : Type u_B) + (N : Type u_N) (G : Type u_G) + [Field k] [CommRing R] [Algebra k R] + [Ring B] [Algebra k B] + [AddCommGroup N] [Module k N] [Module Bᵐᵒᵖ N] + [SMulCommClass k Bᵐᵒᵖ N] + [AddCommGroup G] [Module k G] [Module R G] where + /-- The central square-zero deformation parameter. -/ + c : B + c_center : c ∈ Set.center B + c_sq : c ^ 2 = 0 + /-- Specialization from the deformation ring to the commutative fibre. -/ + pi : B →ₐ[k] R + pi_surjective : Function.Surjective pi + pi_c : pi c = 0 + /-- Action of the deformation parameter on the right module. -/ + cAct : N →ₗ[k] N + cAct_apply : ∀ m, cAct m = MulOpposite.op c • m + c_exact : LinearMap.ker cAct = LinearMap.range cAct + /-- Specialization of the module to its commutative fibre. -/ + rho : N →ₗ[k] G + rho_surjective : Function.Surjective rho + rho_ker : LinearMap.ker rho = LinearMap.range cAct + rho_action : ∀ b m, rho (MulOpposite.op b • m) = pi b • rho m + /-- The `k`-bilinear first-order bracket on the special fibre. -/ + bracket : R →ₗ[k] R →ₗ[k] R + /-- Every deformation-ring commutator is divisible on the left by `c`, + with quotient specializing to the bracket in the displayed input order. -/ + commutator_factor : ∀ a b : B, ∃ z : B, + Stafford.commutator a b = c * z ∧ + pi z = bracket (pi a) (pi b) + +variable {R : Type u_R} {G : Type u_G} +variable [Algebra k B] +variable [CommRing R] [Algebra k R] +variable [AddCommGroup G] [Module k G] [Module R G] + +namespace RightSquareZeroTraceData + +variable (D : RightSquareZeroTraceData k R B N G) + +/-- The recorded parameter action is literally right multiplication by `c`. -/ +theorem cAct_eq_rightActionEnd : + D.cAct = rightActionEnd k B N D.c := by + ext m + exact D.cAct_apply m + +/-- The parameter action squares to zero. -/ +theorem cAct_comp_self : D.cAct.comp D.cAct = 0 := by + ext m + simp only [LinearMap.comp_apply, D.cAct_apply, LinearMap.zero_apply] + rw [← mul_smul] + rw [← MulOpposite.op_mul] + rw [← pow_two, D.c_sq] + exact zero_smul _ _ + +/-- Module specialization kills the parameter action. -/ +theorem rho_comp_cAct : D.rho.comp D.cAct = 0 := by + ext m + simp only [LinearMap.comp_apply, D.cAct_apply, LinearMap.zero_apply] + rw [D.rho_action, D.pi_c, zero_smul] + +/-- Special-fibre elements admit deformation lifts whose commutator has the +recorded first-order factorization. -/ +theorem exists_lifts_commutator_factor (x y : R) : + ∃ a b z : B, + D.pi a = x ∧ D.pi b = y ∧ + Stafford.commutator a b = D.c * z ∧ + D.pi z = D.bracket x y := by + obtain ⟨a, ha⟩ := D.pi_surjective x + obtain ⟨b, hb⟩ := D.pi_surjective y + obtain ⟨z, hz, hbracket⟩ := D.commutator_factor a b + refine ⟨a, b, z, ha, hb, hz, ?_⟩ + simpa [ha, hb] using hbracket + +end RightSquareZeroTraceData + + +end +end Stafford38.Characteristic.SquareZeroTraceData diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/StableTorsionResidualSupport.lean b/LeanPool/Stafford38/Stafford38/Characteristic/StableTorsionResidualSupport.lean new file mode 100644 index 0000000000..a81d81d566 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/StableTorsionResidualSupport.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.StableTorsionResidualSupport +import LeanPool.Stafford38.Stafford38.Characteristic.PrincipalKoszulPositivity + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.StableTorsionResidualSupport + +export AlgebraicAnalysis.StableTorsionResidualSupport (residual_nontrivial_of_support) + +end Stafford38.Characteristic.StableTorsionResidualSupport diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/SymplecticCompletion.lean b/LeanPool/Stafford38/Stafford38/Characteristic/SymplecticCompletion.lean new file mode 100644 index 0000000000..6057157915 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/SymplecticCompletion.lean @@ -0,0 +1,347 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.Symplectic +import LeanPool.Stafford38.Stafford38.Characteristic.HomogeneousChart + +/-! +# Symplectic completion of a phase vector + +An explicit symplectic transvection preserves the standard phase pairing. +One transvection sends a nonzero vector to another when they pair nontrivially; +an elementary bridge vector reduces the remaining case to two transvections. +Consequently any nonzero phase vector can occupy a prescribed matrix column. +Combined with homogeneous nonvanishing, this makes the transformed pure-power +coefficient nonzero over the original characteristic-zero field. +-/ + +namespace Stafford38.CharacteristicSymplecticCompletion + +open Stafford38.Characteristic +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.WeylSymplectic + +noncomputable section +universe u +variable (k : Type u) [Field k] + +def phasePairing {n : ℕ} (u v : PhaseVar n → k) : k := + ∑ i, (u (.inr i) * v (.inl i) - u (.inl i) * v (.inr i)) + +def phaseBasis {n : ℕ} (j : PhaseVar n) : PhaseVar n → k := + fun i => if i = j then 1 else 0 + +def symplecticTransvection {n : ℕ} (a : k) (u : PhaseVar n → k) : + Matrix (PhaseVar n) (PhaseVar n) k := + fun i j => (if i = j then 1 else 0) + + a * phasePairing k (phaseBasis k j) u * u i + +theorem phasePairing_basis_left {n : ℕ} (j : PhaseVar n) + (u : PhaseVar n → k) : + phasePairing k (phaseBasis k j) u = + match j with + | .inl i => -u (.inr i) + | .inr i => u (.inl i) := by + cases j with + | inl j => + simp [phasePairing, phaseBasis] + | inr j => + simp [phasePairing, phaseBasis] + +theorem transvection_mulVec {n : ℕ} (a : k) (u z : PhaseVar n → k) + (i : PhaseVar n) : + Matrix.mulVec (symplecticTransvection k a u) z i = + z i + a * phasePairing k z u * u i := by + simp only [Matrix.mulVec, dotProduct, symplecticTransvection] + simp_rw [add_mul] + rw [Finset.sum_add_distrib] + rw [show (∑ x, (if i = x then 1 else 0) * z x) = z i by simp] + congr 1 + rw [phasePairing] + rw [Fintype.sum_sum_type] + simp only [phasePairing_basis_left] + simp only [Finset.sum_sub_distrib] + rw [mul_sub, sub_mul] + rw [Finset.mul_sum, Finset.mul_sum, Finset.sum_mul, Finset.sum_mul] + rw [← Finset.sum_sub_distrib, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro x hx + ring + +theorem phasePairing_add_left {n : ℕ} (u v w : PhaseVar n → k) : + phasePairing k (u + v) w = phasePairing k u w + phasePairing k v w := by + simp [phasePairing, Finset.sum_add_distrib] + simp_rw [add_mul] + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + ring + +theorem phasePairing_add_right {n : ℕ} (u v w : PhaseVar n → k) : + phasePairing k u (v + w) = phasePairing k u v + phasePairing k u w := by + simp [phasePairing, Finset.sum_add_distrib] + simp_rw [mul_add] + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + ring + +theorem phasePairing_smul_left {n : ℕ} (c : k) (u v : PhaseVar n → k) : + phasePairing k (c • u) v = c * phasePairing k u v := by + simp [phasePairing, Finset.mul_sum] + rw [mul_sub] + rw [Finset.mul_sum, Finset.mul_sum] + congr 1 <;> apply Finset.sum_congr rfl <;> intro x hx <;> ring + +theorem phasePairing_smul_right {n : ℕ} (c : k) (u v : PhaseVar n → k) : + phasePairing k u (c • v) = c * phasePairing k u v := by + simp [phasePairing, Finset.mul_sum] + rw [mul_sub] + rw [Finset.mul_sum, Finset.mul_sum] + congr 1 <;> apply Finset.sum_congr rfl <;> intro x hx <;> ring + +theorem phasePairing_skew {n : ℕ} (u v : PhaseVar n → k) : + phasePairing k u v = -phasePairing k v u := by + simp [phasePairing, Finset.sum_neg_distrib] + congr 1 <;> apply Finset.sum_congr rfl <;> intro x hx <;> ring + +theorem phasePairing_self {n : ℕ} (u : PhaseVar n → k) : + phasePairing k u u = 0 := by + simp [phasePairing] + have hsum : (∑ x, u (.inl x) * u (.inr x)) = + ∑ x, u (.inr x) * u (.inl x) := by + apply Finset.sum_congr rfl + intro x hx + ring + rw [hsum, sub_self] + +theorem transvection_preserves_pairing {n : ℕ} (a : k) + (u x y : PhaseVar n → k) : + phasePairing k (Matrix.mulVec (symplecticTransvection k a u) x) + (Matrix.mulVec (symplecticTransvection k a u) y) = + phasePairing k x y := by + have hx : Matrix.mulVec (symplecticTransvection k a u) x = + x + (a * phasePairing k x u) • u := by + funext i + rw [transvection_mulVec] + rfl + have hy : Matrix.mulVec (symplecticTransvection k a u) y = + y + (a * phasePairing k y u) • u := by + funext i + rw [transvection_mulVec] + rfl + rw [hx, hy, phasePairing_add_left] + simp_rw [phasePairing_add_right, phasePairing_smul_left, + phasePairing_smul_right, phasePairing_self] + rw [phasePairing_skew k u y] + ring + +theorem transpose_standardForm_mul_apply {n : ℕ} + (A : Matrix (PhaseVar n) (PhaseVar n) k) (i j : PhaseVar n) : + (Matrix.transpose A * standardForm k n * A) i j = + phasePairing k (fun l => A l i) (fun l => A l j) := by + simp [Matrix.mul_apply, standardForm, Matrix.J, phasePairing, + Matrix.one_apply] + ring + +theorem phasePairing_basis {n : ℕ} (i j : PhaseVar n) : + phasePairing k (phaseBasis k i) (phaseBasis k j) = + standardForm k n i j := by + cases i <;> cases j <;> + simp [phasePairing, phaseBasis, standardForm, Matrix.J, Matrix.one_apply, + eq_comm] + +theorem mulVec_phaseBasis {n : ℕ} + (A : Matrix (PhaseVar n) (PhaseVar n) k) (j : PhaseVar n) : + Matrix.mulVec A (phaseBasis k j) = fun i => A i j := by + funext i + simp [Matrix.mulVec, dotProduct, phaseBasis] + +theorem symplecticTransvection_mem {n : ℕ} (a : k) + (u : PhaseVar n → k) : + symplecticTransvection k a u ∈ Matrix.symplecticGroup (Fin n) k := by + rw [SymplecticGroup.mem_iff'] + ext i j + rw [transpose_standardForm_mul_apply] + change phasePairing k (fun l => symplecticTransvection k a u l i) + (fun l => symplecticTransvection k a u l j) = standardForm k n i j + rw [← phasePairing_basis k i j] + rw [← mulVec_phaseBasis k (symplecticTransvection k a u) i, + ← mulVec_phaseBasis k (symplecticTransvection k a u) j] + exact transvection_preserves_pairing k a u (phaseBasis k i) (phaseBasis k j) + +theorem phasePairing_sub_right {n : ℕ} (u v w : PhaseVar n → k) : + phasePairing k u (v - w) = phasePairing k u v - phasePairing k u w := by + simp [phasePairing, Finset.sum_sub_distrib] + simp_rw [mul_sub] + rw [Finset.sum_sub_distrib, Finset.sum_sub_distrib] + ring + +theorem exists_phasePairing_right_ne_zero {n : ℕ} + {u : PhaseVar n → k} (hu : u ≠ 0) : + ∃ z : PhaseVar n → k, phasePairing k u z ≠ 0 := by + have hex : ∃ i, u i ≠ 0 := by + by_contra h + push_neg at h + apply hu + funext i + exact h i + rcases hex with ⟨i, hi⟩ + cases i with + | inl i => + refine ⟨phaseBasis k (.inr i), ?_⟩ + simpa [phasePairing, phaseBasis] using neg_ne_zero.mpr hi + | inr i => + refine ⟨phaseBasis k (.inl i), ?_⟩ + simpa [phasePairing, phaseBasis] using hi + +theorem exists_phasePairing_left_ne_zero {n : ℕ} + {u : PhaseVar n → k} (hu : u ≠ 0) : + ∃ z : PhaseVar n → k, phasePairing k z u ≠ 0 := by + rcases exists_phasePairing_right_ne_zero k hu with ⟨z, hz⟩ + refine ⟨z, ?_⟩ + rw [phasePairing_skew k z u] + exact neg_ne_zero.mpr hz + +theorem exists_phasePairing_bridge {n : ℕ} + {e v : PhaseVar n → k} (he : e ≠ 0) (hv : v ≠ 0) : + ∃ w : PhaseVar n → k, + phasePairing k e w ≠ 0 ∧ phasePairing k w v ≠ 0 := by + rcases exists_phasePairing_right_ne_zero k he with ⟨r, her⟩ + rcases exists_phasePairing_left_ne_zero k hv with ⟨s, hsv⟩ + by_cases hrv : phasePairing k r v ≠ 0 + · exact ⟨r, her, hrv⟩ + by_cases hes : phasePairing k e s ≠ 0 + · exact ⟨s, hes, hsv⟩ + refine ⟨r + s, ?_, ?_⟩ + · rw [phasePairing_add_right] + simpa [not_not.mp hes] using her + · rw [phasePairing_add_left] + simpa [not_not.mp hrv] using hsv + +def transvectionSending {n : ℕ} (x y : PhaseVar n → k) : + Matrix (PhaseVar n) (PhaseVar n) k := + symplecticTransvection k (phasePairing k x y)⁻¹ (y - x) + +theorem transvectionSending_mem {n : ℕ} (x y : PhaseVar n → k) : + transvectionSending k x y ∈ Matrix.symplecticGroup (Fin n) k := + symplecticTransvection_mem k _ _ + +theorem transvectionSending_mulVec {n : ℕ} (x y : PhaseVar n → k) + (hxy : phasePairing k x y ≠ 0) : + Matrix.mulVec (transvectionSending k x y) x = y := by + funext i + rw [transvectionSending, transvection_mulVec] + rw [phasePairing_sub_right, phasePairing_self, sub_zero] + rw [inv_mul_cancel₀ hxy] + simp + +theorem exists_symplectic_mulVec_eq {n : ℕ} + {e v : PhaseVar n → k} (he : e ≠ 0) (hv : v ≠ 0) : + ∃ M : Matrix (PhaseVar n) (PhaseVar n) k, + M ∈ Matrix.symplecticGroup (Fin n) k ∧ Matrix.mulVec M e = v := by + by_cases hev : phasePairing k e v ≠ 0 + · exact ⟨transvectionSending k e v, transvectionSending_mem k e v, + transvectionSending_mulVec k e v hev⟩ + rcases exists_phasePairing_bridge k he hv with ⟨w, hew, hwv⟩ + refine ⟨transvectionSending k w v * transvectionSending k e w, ?_, ?_⟩ + · exact (Matrix.symplecticGroup (Fin n) k).mul_mem + (transvectionSending_mem k w v) (transvectionSending_mem k e w) + · rw [← Matrix.mulVec_mulVec] + rw [transvectionSending_mulVec k e w hew] + exact transvectionSending_mulVec k w v hwv + +theorem exists_symplectic_column_eq {n : ℕ} (t : PhaseVar n) + {v : PhaseVar n → k} (hv : v ≠ 0) : + ∃ M : Matrix (PhaseVar n) (PhaseVar n) k, + M ∈ Matrix.symplecticGroup (Fin n) k ∧ (fun i => M i t) = v := by + have hb : phaseBasis k t ≠ 0 := by + intro h + have := congrFun h t + simp [phaseBasis] at this + rcases exists_symplectic_mulVec_eq k hb hv with ⟨M, hM, hMv⟩ + refine ⟨M, hM, ?_⟩ + rw [← mulVec_phaseBasis] + exact hMv + +theorem exists_symplectic_pureCoefficient_ne_zero [CharZero k] + {n N : ℕ} (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) (hN : 0 < N) : + ∃ M : Matrix (PhaseVar n) (PhaseVar n) k, + M ∈ Matrix.symplecticGroup (Fin n) k ∧ + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (Stafford38.CharacteristicLinearAction.symbolLinearAlgHom k M P)) ≠ 0 := by + rcases exists_eval_ne_zero_of_homogeneous k hP hne with ⟨v, hv⟩ + have hvne : v ≠ 0 := by + intro hvzero + subst v + apply hv + have hc : MvPolynomial.coeff 0 P = 0 := + hP.coeff_eq_zero (by simpa using Nat.ne_of_lt hN) + simpa [hc] + rcases exists_symplectic_column_eq k t hvne with ⟨M, hM, hcol⟩ + refine ⟨M, hM, ?_⟩ + rw [pureCoefficient_symbolLinearAlgHom k M t hP] + rw [hcol] + exact hv + +theorem exists_symplectic_chart_matrices [CharZero k] + {n N : ℕ} (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) (hN : 0 < N) : + ∃ M Ninv : Matrix (PhaseVar n) (PhaseVar n) k, + M * standardForm k n * Matrix.transpose M = standardForm k n ∧ + Ninv * standardForm k n * Matrix.transpose Ninv = standardForm k n ∧ + M * Ninv = 1 ∧ Ninv * M = 1 ∧ + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (Stafford38.CharacteristicLinearAction.symbolLinearAlgHom k M P)) ≠ 0 := by + rcases exists_symplectic_pureCoefficient_ne_zero k t hP hne hN with + ⟨M, hM, hcoeff⟩ + let A : Matrix.symplecticGroup (Fin n) k := ⟨M, hM⟩ + let Ninv : Matrix (PhaseVar n) (PhaseVar n) k := ↑(A⁻¹) + refine ⟨M, Ninv, SymplecticGroup.mem_iff.mp hM, + SymplecticGroup.mem_iff.mp (A⁻¹).property, ?_, ?_, hcoeff⟩ + · dsimp only [Ninv] + calc + M * (↑(A⁻¹) : Matrix (PhaseVar n) (PhaseVar n) k) = ↑(A * A⁻¹) := rfl + _ = ↑(1 : Matrix.symplecticGroup (Fin n) k) := by simp + _ = 1 := rfl + · dsimp only [Ninv] + calc + (↑(A⁻¹) : Matrix (PhaseVar n) (PhaseVar n) k) * M = ↑(A⁻¹ * A) := rfl + _ = ↑(1 : Matrix.symplecticGroup (Fin n) k) := by simp + _ = 1 := rfl + +/- Exact statement pins for symplectic column completion and the monic-symbol +precursor. -/ +theorem symplectic_column_statement {n : ℕ} (t : PhaseVar n) + {v : PhaseVar n → k} (hv : v ≠ 0) : + ∃ M : Matrix (PhaseVar n) (PhaseVar n) k, + M ∈ Matrix.symplecticGroup (Fin n) k ∧ (fun i => M i t) = v := + exists_symplectic_column_eq k t hv + +theorem symplectic_pureCoefficient_statement [CharZero k] + {n N : ℕ} (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) (hN : 0 < N) : + ∃ M : Matrix (PhaseVar n) (PhaseVar n) k, + M ∈ Matrix.symplecticGroup (Fin n) k ∧ + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (Stafford38.CharacteristicLinearAction.symbolLinearAlgHom k M P)) ≠ 0 := + exists_symplectic_pureCoefficient_ne_zero k t hP hne hN + +theorem symplectic_chart_matrices_statement [CharZero k] + {n N : ℕ} (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) (hne : P ≠ 0) (hN : 0 < N) : + ∃ M Ninv : Matrix (PhaseVar n) (PhaseVar n) k, + M * standardForm k n * Matrix.transpose M = standardForm k n ∧ + Ninv * standardForm k n * Matrix.transpose Ninv = standardForm k n ∧ + M * Ninv = 1 ∧ Ninv * M = 1 ∧ + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (Stafford38.CharacteristicLinearAction.symbolLinearAlgHom k M P)) ≠ 0 := + exists_symplectic_chart_matrices k t hP hne hN + + +end +end Stafford38.CharacteristicSymplecticCompletion diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/TransposedFilteredModuleSupport.lean b/LeanPool/Stafford38/Stafford38/Characteristic/TransposedFilteredModuleSupport.lean new file mode 100644 index 0000000000..9e4ae4b1f7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/TransposedFilteredModuleSupport.lean @@ -0,0 +1,342 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import LeanPool.Stafford38.Stafford38.Weyl.TranspositionFiltration + +/-! +# Transposition of the filtered right quotient and its support + +This file turns the concrete order filtration on a right Weyl quotient into +the corresponding filtration of the transposed left module. On associated +graded modules the transported action is momentum-sign substitution. The +resulting support is therefore the inverse image of the original support +under `symbolTranspositionEquiv`. + +No noncharacteristic restriction theorem or D-module comparison theorem is +used here. +-/ + +namespace Stafford38.CharacteristicTransposedFilteredModuleSupport + +open Stafford38.Characteristic +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.EulerSurjectivity +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylTransposition +open Stafford38.WeylTranspositionFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-! ## The transported filtered quotient -/ + +/-- The actual right quotient, regarded as a distinct type so that it can +carry the left Weyl action obtained by transposition. -/ +structure TransposedFilteredRightQuotient + (I : RightIdeal (PresentedWeyl k n)) where + /-- The underlying class in the original right quotient. -/ + toRightQuotient : RightQuotient I + +/-- Forget the transported structure. -/ +def transposedFilteredRightQuotientEquiv + (I : RightIdeal (PresentedWeyl k n)) : + TransposedFilteredRightQuotient k I ≃ RightQuotient I where + toFun := TransposedFilteredRightQuotient.toRightQuotient + invFun := TransposedFilteredRightQuotient.mk + left_inv q := by cases q; rfl + right_inv _ := rfl + +instance (I : RightIdeal (PresentedWeyl k n)) : AddCommGroup + (TransposedFilteredRightQuotient k I) := + Equiv.addCommGroup (transposedFilteredRightQuotientEquiv k I) + +/-- Additive form of the forgetful equivalence. -/ +def transposedFilteredRightQuotientAddEquiv + (I : RightIdeal (PresentedWeyl k n)) : + TransposedFilteredRightQuotient k I ≃+ RightQuotient I := + Equiv.addEquiv (transposedFilteredRightQuotientEquiv k I) + +instance (I : RightIdeal (PresentedWeyl k n)) : Module k + (TransposedFilteredRightQuotient k I) := + (transposedFilteredRightQuotientAddEquiv k I).module k + +/-- The quotient's right action restricted along Weyl transposition. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + Module (PresentedWeyl k n) (TransposedFilteredRightQuotient k I) := + letI : Module (PresentedWeyl k n) (RightQuotient I) := + transposedLeftModule k n (RightQuotient I) + (transposedFilteredRightQuotientAddEquiv k I).module + (PresentedWeyl k n) + +/-- The canonical identification with the filtered `k`-linear quotient. -/ +def filteredQuotientToTransposedLinearEquiv + (I : RightIdeal (PresentedWeyl k n)) : + FilteredRightQuotient k I ≃ₗ[k] TransposedFilteredRightQuotient k I := + (filteredRightQuotientEquivRightQuotient k I).trans + { (transposedFilteredRightQuotientAddEquiv k I).symm with + map_smul' := by intro c q; rfl } + +/-- The transported degree-`N` filtration piece. -/ +def transposedQuotientOrderPiece + (I : RightIdeal (PresentedWeyl k n)) (N : ℕ) : + Submodule k (TransposedFilteredRightQuotient k I) := + (quotientOrderPiece k I N).map + (filteredQuotientToTransposedLinearEquiv k I).toLinearMap + +/-- The transported quotient filtration is increasing. -/ +theorem transposedQuotientOrderPiece_mono + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} (hNM : N ≤ M) : + transposedQuotientOrderPiece k I N ≤ + transposedQuotientOrderPiece k I M := + Submodule.map_mono (Submodule.map_mono + (presentedWeightPiece_mono k orderWeight hNM)) + +@[simp] theorem filteredQuotientToTransposedLinearEquiv_mk + (I : RightIdeal (PresentedWeyl k n)) (a : PresentedWeyl k n) : + filteredQuotientToTransposedLinearEquiv k I + (Submodule.Quotient.mk a) = + TransposedFilteredRightQuotient.mk (qmk I a) := + rfl + +@[simp] theorem transposed_smul_qmk + (I : RightIdeal (PresentedWeyl k n)) + (a b : PresentedWeyl k n) : + a • TransposedFilteredRightQuotient.mk (qmk I b) = + TransposedFilteredRightQuotient.mk + (qmk I (b * transpose k n a)) := by + apply (transposedFilteredRightQuotientEquiv k I).injective + change rightMul I (transpose k n a) (qmk I b) = + qmk I (b * transpose k n a) + exact (qmk_right_mul I b (transpose k n a)).symm + +/-- The transported filtration is compatible with the transposed left +action: an operator of order at most `M` sends the degree-`N` piece into the +degree-`N+M` piece. -/ +theorem smul_mem_transposedQuotientOrderPiece + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} + {a : PresentedWeyl k n} (ha : a ∈ orderPiece k n M) + {q : TransposedFilteredRightQuotient k I} + (hq : q ∈ transposedQuotientOrderPiece k I N) : + a • q ∈ transposedQuotientOrderPiece k I (N + M) := by + rcases hq with ⟨q₀, hq₀, rfl⟩ + rcases hq₀ with ⟨z, hz, rfl⟩ + refine ⟨(Submodule.Quotient.mk + (z * transpose k n a) : FilteredRightQuotient k I), ?_, ?_⟩ + · exact ⟨z * transpose k n a, + mul_mem_orderPiece k hz (transpose_mem_orderPiece k ha), rfl⟩ + · exact (transposed_smul_qmk k I a z).symm + +/-- Every quotient class occurs in a finite transported order piece. -/ +theorem exists_mem_transposedQuotientOrderPiece + (I : RightIdeal (PresentedWeyl k n)) + (q : TransposedFilteredRightQuotient k I) : + ∃ N, q ∈ transposedQuotientOrderPiece k I N := by + rcases q with ⟨q⟩ + refine Submodule.Quotient.induction_on I q ?_ + intro z + obtain ⟨N, hz⟩ := exists_mem_orderPiece k z + refine ⟨N, Submodule.mem_map.mpr ⟨Submodule.Quotient.mk z, ?_, rfl⟩⟩ + exact Submodule.mem_map.mpr ⟨z, hz, rfl⟩ + +/-- Cyclic good-filtration form: every class in degree `N` is obtained by an +operator in `F_N A` acting on the class of one. -/ +theorem exists_filtered_smul_one_of_mem + (I : RightIdeal (PresentedWeyl k n)) {N : ℕ} + (q : TransposedFilteredRightQuotient k I) + (hq : q ∈ transposedQuotientOrderPiece k I N) : + ∃ a : PresentedWeyl k n, a ∈ orderPiece k n N ∧ + q = a • TransposedFilteredRightQuotient.mk (qmk I 1) := by + rcases hq with ⟨q₀, hq₀, rfl⟩ + rcases hq₀ with ⟨z, hz, rfl⟩ + refine ⟨transpose k n z, transpose_mem_orderPiece k hz, ?_⟩ + change filteredQuotientToTransposedLinearEquiv k I + (Submodule.Quotient.mk z) = + transpose k n z • TransposedFilteredRightQuotient.mk (qmk I 1) + rw [filteredQuotientToTransposedLinearEquiv_mk, + transposed_smul_qmk, transpose_transpose, one_mul] + +/-! ## The transported associated graded module -/ + +/-- The actual associated graded object with scalar action restricted along +momentum-sign substitution. -/ +structure TransposedOrderAssociatedGradedModule + (I : RightIdeal (PresentedWeyl k n)) where + /-- The underlying class in the original associated graded module. -/ + toOrderAssociatedGradedModule : OrderAssociatedGradedModule k I + +/-- Forget the transported symbol action. -/ +def transposedOrderAssociatedGradedEquiv + (I : RightIdeal (PresentedWeyl k n)) : + TransposedOrderAssociatedGradedModule k I ≃ + OrderAssociatedGradedModule k I where + toFun := TransposedOrderAssociatedGradedModule.toOrderAssociatedGradedModule + invFun := TransposedOrderAssociatedGradedModule.mk + left_inv q := by cases q; rfl + right_inv _ := rfl + +instance (I : RightIdeal (PresentedWeyl k n)) : AddCommGroup + (TransposedOrderAssociatedGradedModule k I) := + Equiv.addCommGroup (transposedOrderAssociatedGradedEquiv k I) + +/-- Additive form of the forgetful equivalence. -/ +def transposedOrderAssociatedGradedAddEquiv + (I : RightIdeal (PresentedWeyl k n)) : + TransposedOrderAssociatedGradedModule k I ≃+ + OrderAssociatedGradedModule k I := + Equiv.addEquiv (transposedOrderAssociatedGradedEquiv k I) + +/-- Symbol action on the transposed associated graded module. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + Module (SymbolRing k n) (TransposedOrderAssociatedGradedModule k I) := + letI : Module (SymbolRing k n) (OrderAssociatedGradedModule k I) := + Module.compHom (OrderAssociatedGradedModule k I) + (symbolTranspositionEquiv k).toRingEquiv.toRingHom + (transposedOrderAssociatedGradedAddEquiv k I).module (SymbolRing k n) + +@[simp] theorem transposedSymbol_smul + (I : RightIdeal (PresentedWeyl k n)) + (P : SymbolRing k n) (q : TransposedOrderAssociatedGradedModule k I) : + (P • q).toOrderAssociatedGradedModule = + symbolTransposition k P • q.toOrderAssociatedGradedModule := + rfl + +/-- The associated graded action is the one induced by the filtered +transposed action: on representatives it multiplies on the right by the +transpose of the acting Weyl operator. -/ +theorem transposedSymbol_smul_of_mk_eq_transpose_mul + (I : RightIdeal (PresentedWeyl k n)) {N M : ℕ} + (z : orderPiece k n N) (a : orderPiece k n M) : + (presentedPrincipalComponent k orderWeight M a : SymbolRing k n) • + TransposedOrderAssociatedGradedModule.mk + (orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z)) = + TransposedOrderAssociatedGradedModule.mk + (orderAssociatedGradedOf k I (N + M) + (orderPieceToQuotientGraded k I (N + M) + ⟨(z : PresentedWeyl k n) * transpose k n a, + mul_mem_orderPiece k z.property + (transpose_mem_orderPiece k a.property)⟩)) := by + apply (transposedOrderAssociatedGradedEquiv k I).injective + change symbolTransposition k + (presentedPrincipalComponent k (@orderWeight n) M a) • + orderAssociatedGradedOf k I N + (orderPieceToQuotientGraded k I N z) = _ + rw [← principal_transpose_order k a.property] + exact smul_orderAssociatedGradedOf_mk_eq_of_mul k I z + ⟨transpose k n a, transpose_mem_orderPiece k a.property⟩ + +/-- The annihilator of the transported associated graded module is the +inverse image of the original annihilator under symbol transposition. -/ +theorem annihilator_transposedOrderAssociatedGradedModule + (I : RightIdeal (PresentedWeyl k n)) : + Module.annihilator (SymbolRing k n) + (TransposedOrderAssociatedGradedModule k I) = + (Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I)).comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom := by + ext P + simp only [Module.mem_annihilator, Ideal.mem_comap] + constructor <;> intro h q + · have hq := congrArg + TransposedOrderAssociatedGradedModule.toOrderAssociatedGradedModule + (h (TransposedOrderAssociatedGradedModule.mk q)) + exact hq + · apply (transposedOrderAssociatedGradedEquiv k I).injective + exact h q.toOrderAssociatedGradedModule + +/-- The original actual associated graded quotient is cyclic and therefore +finite over the symbol ring. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + Module.Finite (SymbolRing k n) (OrderAssociatedGradedModule k I) := by + let g := orderAssociatedGradedGenerator k I + let f : SymbolRing k n →ₗ[SymbolRing k n] + OrderAssociatedGradedModule k I := + { toFun := fun P => P • g + map_add' := by intro P Q; exact add_smul P Q g + map_smul' := by intro P Q; exact mul_smul P Q g } + apply Module.Finite.of_surjective f + intro q + exact exists_smul_orderAssociatedGradedGenerator k I q + +/-- The transported associated graded module remains cyclic, hence finite. -/ +noncomputable instance (I : RightIdeal (PresentedWeyl k n)) : + Module.Finite (SymbolRing k n) + (TransposedOrderAssociatedGradedModule k I) := by + let g : TransposedOrderAssociatedGradedModule k I := + TransposedOrderAssociatedGradedModule.mk + (orderAssociatedGradedGenerator k I) + let f : SymbolRing k n →ₗ[SymbolRing k n] + TransposedOrderAssociatedGradedModule k I := + { toFun := fun P => P • g + map_add' := by intro P Q; exact add_smul P Q g + map_smul' := by intro P Q; exact mul_smul P Q g } + apply Module.Finite.of_surjective f + intro q + obtain ⟨P, hP⟩ := exists_smul_orderAssociatedGradedGenerator k I + q.toOrderAssociatedGradedModule + refine ⟨symbolTransposition k P, ?_⟩ + apply (transposedOrderAssociatedGradedEquiv k I).injective + change symbolTransposition k (symbolTransposition k P) • + orderAssociatedGradedGenerator k I = q.toOrderAssociatedGradedModule + rw [show symbolTransposition k (symbolTransposition k P) = P by + exact AlgHom.congr_fun (symbolTransposition_comp_self k) P] + exact hP + +/-- Support of the transposed associated graded module. -/ +def transposedOrderAssociatedGradedSupport + (I : RightIdeal (PresentedWeyl k n)) : + Set (PrimeSpectrum (SymbolRing k n)) := + Module.support (SymbolRing k n) + (TransposedOrderAssociatedGradedModule k I) + +/-- Transposition carries associated-graded support by the expected +momentum-sign automorphism of the symbol spectrum. -/ +theorem transposedOrderAssociatedGradedSupport_eq_preimage + (I : RightIdeal (PresentedWeyl k n)) : + transposedOrderAssociatedGradedSupport k I = + PrimeSpectrum.comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom ⁻¹' + Module.support (SymbolRing k n) + (OrderAssociatedGradedModule k I) := by + rw [transposedOrderAssociatedGradedSupport, + Module.support_eq_zeroLocus, Module.support_eq_zeroLocus, + annihilator_transposedOrderAssociatedGradedModule] + ext p + simp only [PrimeSpectrum.mem_zeroLocus, Set.mem_preimage, + PrimeSpectrum.comap_asIdeal, SetLike.coe_subset_coe] + constructor + · intro h P hP + have hP' : symbolTransposition k P ∈ + (Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I)).comap + (symbolTranspositionEquiv k).toRingEquiv.toRingHom := by + change symbolTransposition k (symbolTransposition k P) ∈ + Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I) + rwa [show symbolTransposition k (symbolTransposition k P) = P by + exact AlgHom.congr_fun (symbolTransposition_comp_self k) P] + exact h hP' + · intro h P hP + have hP' : symbolTransposition k P ∈ + Module.annihilator (SymbolRing k n) + (OrderAssociatedGradedModule k I) := hP + have h' := h hP' + change symbolTransposition k (symbolTransposition k P) ∈ p.asIdeal at h' + rwa [show symbolTransposition k (symbolTransposition k P) = P by + exact AlgHom.congr_fun (symbolTransposition_comp_self k) P] at h' + + +end + +end Stafford38.CharacteristicTransposedFilteredModuleSupport diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/TwoTermPageLength.lean b/LeanPool/Stafford38/Stafford38/Characteristic/TwoTermPageLength.lean new file mode 100644 index 0000000000..0dd0f48ddc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/TwoTermPageLength.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.TwoTermPageLength + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +namespace Stafford38.Characteristic.TwoTermPageLength + +export AlgebraicAnalysis.TwoTermPageLength (exists_boundary_eq_top_of_iSup_eq_top twoTermPage_length_target_le_source) + +end Stafford38.Characteristic.TwoTermPageLength diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/UniformBoundaryVanishing.lean b/LeanPool/Stafford38/Stafford38/Characteristic/UniformBoundaryVanishing.lean new file mode 100644 index 0000000000..21ba26926c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/UniformBoundaryVanishing.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.UniformBoundaryVanishing + +/- Compatibility exports for the neutral AlgebraicAnalysis API. -/ + +export AlgebraicAnalysis (exists_uniform_zero_of_noetherian + exists_uniform_subsingleton_of_noetherian exists_uniform_zero_localized + exists_uniform_subsingleton_localized) diff --git a/LeanPool/Stafford38/Stafford38/Characteristic/ZeroSectionContainment.lean b/LeanPool/Stafford38/Stafford38/Characteristic/ZeroSectionContainment.lean new file mode 100644 index 0000000000..2bce578be8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Characteristic/ZeroSectionContainment.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous +import LeanPool.Stafford38.Stafford38.Characteristic.ReducedSupportIdeal + +/-! +# Zero-section containment of the reduced order support + +The differential-order initial ideal is homogeneous for fibre degree. At the +level of field-valued points this forces every fibre-conical support fibre to +contain its zero: if `(y, ξ)` is a common zero of the reduced order support +ideal, then `(y, 0)` is a common zero as well. + +The proof does not assume conicality of the radical. For an element of the +radical, it takes a power in the order initial ideal, extracts its fibre-degree +zero component there, and then uses reducedness of the ground field. +-/ + +namespace Stafford38.Characteristic.ZeroSectionContainment + +open Stafford38.Characteristic +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +private abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (n := n) k) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- Evaluation of the fibre-degree-zero component at `(y, ξ)` is evaluation +of the original polynomial at `(y, 0)`. -/ +private theorem eval_zeroComponent + (y ξ : Fin n → k) (P : SymbolRing k n) : + MvPolynomial.eval (Sum.elim y ξ) + (DirectSum.decompose (orderDecomposition (n := n) k) P 0 : + SymbolRing k n) = + MvPolynomial.eval (zeroSectionPoint y) P := by + induction P using MvPolynomial.induction_on with + | C a => + have hC : MvPolynomial.C a ∈ orderDecomposition (n := n) k 0 := + MvPolynomial.isWeightedHomogeneous_C (@orderWeight n) a + let C0 : orderDecomposition (n := n) k 0 := ⟨MvPolynomial.C a, hC⟩ + have hd := congrArg (fun z => z 0) + (DirectSum.decompose_coe (orderDecomposition (n := n) k) C0) + have hd' : (DirectSum.decompose (orderDecomposition (n := n) k) + (MvPolynomial.C a) 0 : SymbolRing k n) = MvPolynomial.C a := by + simpa [C0] using congrArg Subtype.val hd + rw [hd'] + simp + | add P Q hP hQ => + rw [DirectSum.decompose_add] + change MvPolynomial.eval (Sum.elim y ξ) + ((DirectSum.decompose (orderDecomposition (n := n) k) P 0 : + SymbolRing k n) + + (DirectSum.decompose (orderDecomposition (n := n) k) Q 0 : + SymbolRing k n)) = _ + simp only [MvPolynomial.eval_add, hP, hQ] + | mul_X P i hP => + rcases i with i | i + · have hX : MvPolynomial.X (Sum.inl i : PhaseVar n) ∈ + orderDecomposition (n := n) k 0 := by + exact MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) + (Sum.inl i) + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition (n := n) k) hX (Nat.zero_le 0)] + simp only [Nat.zero_sub, MvPolynomial.eval_mul, hP, + MvPolynomial.eval_X] + rfl + · have hX : MvPolynomial.X (Sum.inr i : PhaseVar n) ∈ + orderDecomposition (n := n) k 1 := by + exact MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) + (Sum.inr i) + rw [DirectSum.coe_decompose_mul_of_right_mem_of_not_le + (orderDecomposition (n := n) k) hX (by omega)] + simp [zeroSectionPoint] + +/-- A field-valued common zero of the reduced order support ideal remains a +common zero after its fibre coordinate is set to zero. -/ +theorem zeroSection_mem_of_mem_reducedOrderSupport_zeroSet + (I : RightIdeal (PresentedWeyl k n)) (y ξ : Fin n → k) + (hpoint : ∀ P ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (Sum.elim y ξ) P = 0) : + ∀ P ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (zeroSectionPoint y) P = 0 := by + intro P hP + obtain ⟨m, hm⟩ := (mem_reducedOrderSupportIdeal_iff k I P).mp hP + have hcomponent : + (DirectSum.decompose (orderDecomposition (n := n) k) (P ^ m) 0 : + SymbolRing k n) ∈ orderInitialIdeal k I := + coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k I 0 + (DirectSum.decompose (orderDecomposition (n := n) k) (P ^ m) 0) + (decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k I (P ^ m) hm 0) + have hevalComponent := hpoint _ + (orderInitialIdeal_le_reducedOrderSupportIdeal k I hcomponent) + rw [eval_zeroComponent k y ξ (P ^ m)] at hevalComponent + rw [map_pow] at hevalComponent + exact (pow_eq_zero_iff'.mp hevalComponent).1 + + +end + +end Stafford38.Characteristic.ZeroSectionContainment diff --git a/LeanPool/Stafford38/Stafford38/CoordinateDifferentialGeneration.lean b/LeanPool/Stafford38/Stafford38/CoordinateDifferentialGeneration.lean new file mode 100644 index 0000000000..9b361ffae7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/CoordinateDifferentialGeneration.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration + +/-! Compatibility exports for the reusable coordinate-generation argument. -/ +namespace Stafford38.CoordinateDifferentialGeneration + +export AlgebraicAnalysis.DifferentialOperators.CoordinateGeneration + (mem_submodule_of_coordinates mem_subalgebra_of_coordinates) + +end Stafford38.CoordinateDifferentialGeneration diff --git a/LeanPool/Stafford38/Stafford38/DifferentialOperators.lean b/LeanPool/Stafford38/Stafford38/DifferentialOperators.lean new file mode 100644 index 0000000000..a11833a916 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/DifferentialOperators.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.Basic + +/-! Compatibility aliases for the neutral AlgebraicAnalysis differential +operator API. -/ + +namespace Stafford38.DifferentialOperators + +export AlgebraicAnalysis.DifferentialOperators + (End multiplication commutator order algebra + multiplication_apply commutator_apply mem_order_zero_iff mem_order_succ_iff + mem_order_zero_iff_eq_multiplication order_mono_step order_mono commutator_mul + mul_mem_order mem_algebra_iff) + +end Stafford38.DifferentialOperators diff --git a/LeanPool/Stafford38/Stafford38/EulerRootSeparation.lean b/LeanPool/Stafford38/Stafford38/EulerRootSeparation.lean new file mode 100644 index 0000000000..7b5db510d0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/EulerRootSeparation.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib +import LeanPool.Stafford38.Stafford38.EvolutionaryCertificate + +/-! +# The Euler root line and the Bézout hypothesis + +The evolutionary Stafford certificate of `Stafford38.EvolutionaryCertificate` +consumes one Bézout identity: the Euler corner polynomial + + C_r = R₊ - R₋, R₊ = (X+1)⋯(X+r), R₋ = X(X-1)⋯(X-r+1) + +must be coprime to `R₊` and to each of its own positive integer shifts +`C_r(X + n)`, `n ≥ 1`. This file discharges that hypothesis. + +The mechanism is a one-dimensional root separation. For `i ≥ 1`, + + |z + i|² - |z - (i-1)|² = (2i - 1)(2 Re z + 1), + +so on `Re z > -1/2` every rising factor strictly dominates the corresponding +falling factor and on `Re z < -1/2` every one is strictly dominated. Hence + + C_r(z) = 0 ⟹ Re z = -1/2, + +and all roots of `C_r` lie on a single vertical line. Coprimality with `R₊` +follows because the roots of `R₊` are the negative integers, and coprimality +with every positive shift follows because the line `Re z = -1/2` is disjoint +from its own translates. + +Everything is proved over `ℂ`, descended to `ℚ` by `Polynomial.isCoprime_map`, +and transported to an arbitrary characteristic-zero field by `IsCoprime.map`. +-/ + +namespace Stafford38.Evolution + +open Polynomial + +/-- Over `ℂ` regarded as a `ℂ`-algebra, `aeval` is ordinary evaluation. -/ +lemma aeval_eq_eval_complex (z : ℂ) (f : ℂ[X]) : aeval z f = f.eval z := by + rfl + +/-! ## The factorwise comparison -/ + +/-- The exact difference of squared moduli of one rising and one falling +factor. This single computation drives the whole file. -/ +lemma normSq_sub_normSq (z : ℂ) (i : ℕ) : + Complex.normSq (z + ((i : ℂ) + 1)) - Complex.normSq (z - (i : ℂ)) + = (2 * (i : ℝ) + 1) * (2 * z.re + 1) := by + simp only [Complex.normSq_apply, Complex.add_re, Complex.add_im, Complex.sub_re, + Complex.sub_im, Complex.natCast_re, Complex.natCast_im, Complex.one_re, Complex.one_im] + ring + +lemma abs_lt_of_re_pos {z : ℂ} (hz : 0 < 2 * z.re + 1) (i : ℕ) : + ‖z - (i : ℂ)‖ < ‖z + ((i : ℂ) + 1)‖ := by + have hpos : 0 < (2 * (i : ℝ) + 1) * (2 * z.re + 1) := by positivity + have h := normSq_sub_normSq z i + have hlt : Complex.normSq (z - (i : ℂ)) < Complex.normSq (z + ((i : ℂ) + 1)) := by linarith + simpa [Complex.norm_def] using + (Real.sqrt_lt_sqrt (Complex.normSq_nonneg _) hlt) + +lemma abs_lt_of_re_neg {z : ℂ} (hz : 2 * z.re + 1 < 0) (i : ℕ) : + ‖z + ((i : ℂ) + 1)‖ < ‖z - (i : ℂ)‖ := by + have hpos : 0 < (2 * (i : ℝ) + 1) := by positivity + have h := normSq_sub_normSq z i + have hlt : Complex.normSq (z + ((i : ℂ) + 1)) < Complex.normSq (z - (i : ℂ)) := by + nlinarith [h, hpos, hz] + simpa [Complex.norm_def] using + (Real.sqrt_lt_sqrt (Complex.normSq_nonneg _) hlt) + +/-! ## Strict domination of the whole product -/ + +lemma abs_falling_lt_rising {z : ℂ} (hz : 0 < 2 * z.re + 1) : + ∀ r : ℕ, 1 ≤ r → ‖falling z r‖ < ‖rising z r‖ + | 0, h => absurd h (by norm_num) + | 1, _ => by + simpa [rising_succ, falling_succ] using abs_lt_of_re_pos hz 0 + | (r + 2), _ => by + have ih := abs_falling_lt_rising hz (r + 1) (by omega) + have hfac := abs_lt_of_re_pos hz (r + 1) + rw [rising_succ, falling_succ, norm_mul, norm_mul] + exact mul_lt_mul'' ih (by simpa using hfac) (by positivity) (by positivity) + +lemma abs_rising_lt_falling {z : ℂ} (hz : 2 * z.re + 1 < 0) : + ∀ r : ℕ, 1 ≤ r → ‖rising z r‖ < ‖falling z r‖ + | 0, h => absurd h (by norm_num) + | 1, _ => by + simpa [rising_succ, falling_succ] using abs_lt_of_re_neg hz 0 + | (r + 2), _ => by + have ih := abs_rising_lt_falling hz (r + 1) (by omega) + have hfac := abs_lt_of_re_neg hz (r + 1) + rw [rising_succ, falling_succ, norm_mul, norm_mul] + exact mul_lt_mul'' ih (by simpa using hfac) (by positivity) (by positivity) + +/-- **The Euler root line.** Every complex root of the corner polynomial `C_r` +has real part `-1/2`. -/ +theorem re_eq_neg_half_of_isRoot {r : ℕ} (hr : 1 ≤ r) {z : ℂ} + (hz : (cornerPoly ℂ r).IsRoot z) : z.re = -(1 / 2) := by + have heval : rising z r - falling z r = 0 := by + rw [← aeval_cornerPoly (k := ℂ) z r, aeval_eq_eval_complex] + exact hz + have heq : rising z r = falling z r := sub_eq_zero.mp heval + have habs : ‖rising z r‖ = ‖falling z r‖ := by rw [heq] + by_contra hne + rcases lt_trichotomy (2 * z.re + 1) 0 with h | h | h + · exact absurd habs (ne_of_lt (abs_rising_lt_falling h r hr)) + · exact hne (by linarith) + · exact absurd habs.symm (ne_of_lt (abs_falling_lt_rising h r hr)) + +/-! ## The corner polynomial is nonzero, and `R₊` has no root on the line -/ + +lemma falling_zero_eq_zero : ∀ r : ℕ, 1 ≤ r → falling (0 : ℂ) r = 0 + | 0, h => absurd h (by norm_num) + | 1, _ => by simp [falling_succ] + | (r + 2), _ => by + rw [falling_succ, falling_zero_eq_zero (r + 1) (by omega), zero_mul] + +lemma rising_ne_zero_of_re_neg_half {z : ℂ} (hz : z.re = -(1 / 2)) : + ∀ r : ℕ, rising z r ≠ 0 + | 0 => by simp + | (r + 1) => by + rw [rising_succ] + refine mul_ne_zero (rising_ne_zero_of_re_neg_half hz r) ?_ + intro hcon + have : (z + ((r : ℂ) + 1)).re = 0 := by rw [hcon]; simp + simp only [Complex.add_re, Complex.natCast_re, Complex.one_re, hz] at this + have : (0 : ℝ) < (r : ℝ) + 1 := by positivity + linarith + +lemma rising_zero_ne_zero : ∀ r : ℕ, rising (0 : ℂ) r ≠ 0 + | 0 => by simp + | (r + 1) => by + rw [rising_succ] + refine mul_ne_zero (rising_zero_ne_zero r) ?_ + have : (0 : ℝ) < (r : ℝ) + 1 := by positivity + intro hcon + have hre : ((0 : ℂ) + ((r : ℂ) + 1)).re = 0 := by rw [hcon]; simp + simp only [Complex.add_re, Complex.zero_re, Complex.natCast_re, Complex.one_re] at hre + linarith + +lemma cornerPoly_ne_zero {r : ℕ} (hr : 1 ≤ r) : cornerPoly ℂ r ≠ 0 := by + intro hcon + have h0 : aeval (0 : ℂ) (cornerPoly ℂ r) = 0 := by rw [hcon]; simp + rw [aeval_cornerPoly, falling_zero_eq_zero r hr, sub_zero] at h0 + exact rising_zero_ne_zero r h0 + +/-! ## Coprimality over `ℂ` -/ + +lemma isCoprime_of_no_common_root {f g : ℂ[X]} (hf : f ≠ 0) + (h : ∀ z : ℂ, f.IsRoot z → g.IsRoot z → False) : IsCoprime f g := by + classical + rw [← EuclideanDomain.gcd_isUnit_iff] + by_contra hu + have hg0 : EuclideanDomain.gcd f g ≠ 0 := by + intro hcon + exact hf (EuclideanDomain.gcd_eq_zero_iff.mp hcon).1 + have hdeg : 0 < (EuclideanDomain.gcd f g).degree := by + have hne : (EuclideanDomain.gcd f g).degree ≠ 0 := fun hcon => + hu (Polynomial.isUnit_iff_degree_eq_zero.mpr hcon) + exact lt_of_le_of_ne (Polynomial.zero_le_degree_iff.mpr hg0) (Ne.symm hne) + obtain ⟨z, hz⟩ := Complex.exists_root hdeg + rw [Polynomial.isRoot_gcd_iff_isRoot_left_right] at hz + exact h z hz.1 hz.2 + +/-- `C_r` is coprime to the rising factorial `R₊`: the roots of `R₊` are +negative integers, and none of them lies on the line `Re = -1/2`. -/ +theorem isCoprime_corner_rising_complex {r : ℕ} (hr : 1 ≤ r) : + IsCoprime (cornerPoly ℂ r) (risingPoly ℂ r) := by + refine isCoprime_of_no_common_root (cornerPoly_ne_zero hr) ?_ + intro z hzc hzr + have hre := re_eq_neg_half_of_isRoot hr hzc + have hzero : rising z r = 0 := by + rw [← aeval_risingPoly (k := ℂ) z r, aeval_eq_eval_complex] + exact hzr + exact rising_ne_zero_of_re_neg_half hre r hzero + +/-- `C_r` is coprime to each of its own positive integer shifts: the line +`Re = -1/2` is disjoint from every translate of itself. -/ +theorem isCoprime_corner_shift_complex {r : ℕ} (hr : 1 ≤ r) {n : ℕ} (hn : 1 ≤ n) : + IsCoprime (cornerPoly ℂ r) ((cornerPoly ℂ r).comp (X + Polynomial.C (n : ℂ))) := by + refine isCoprime_of_no_common_root (cornerPoly_ne_zero hr) ?_ + intro z hzc hzs + have h1 := re_eq_neg_half_of_isRoot hr hzc + have hroot : (cornerPoly ℂ r).IsRoot (z + (n : ℂ)) := by + simpa [Polynomial.IsRoot, Polynomial.eval_comp] using hzs + have h2 := re_eq_neg_half_of_isRoot hr hroot + simp only [Complex.add_re, Complex.natCast_re, h1] at h2 + have : (1 : ℝ) ≤ (n : ℝ) := by exact_mod_cast hn + linarith + +/-! ## Descent to an arbitrary characteristic-zero field -/ + +section Transport + +variable {k K : Type*} [CommRing k] [CommRing K] + +lemma map_risingPoly (φ : k →+* K) : ∀ n : ℕ, (risingPoly k n).map φ = risingPoly K n + | 0 => by simp + | (n + 1) => by + rw [risingPoly_succ, Polynomial.map_mul, map_risingPoly φ n, risingPoly_succ] + simp + +lemma map_fallingPoly (φ : k →+* K) : ∀ n : ℕ, (fallingPoly k n).map φ = fallingPoly K n + | 0 => by simp + | (n + 1) => by + rw [fallingPoly_succ, Polynomial.map_mul, map_fallingPoly φ n, fallingPoly_succ] + simp + +lemma map_cornerPoly (φ : k →+* K) (r : ℕ) : + (cornerPoly k r).map φ = cornerPoly K r := by + simp [cornerPoly, Polynomial.map_sub, map_risingPoly, map_fallingPoly] + +end Transport + +variable {k : Type*} [Field k] [CharZero k] + +/-- `C_r` and `R₊` are coprime over every characteristic-zero field. -/ +theorem isCoprime_corner_rising {r : ℕ} (hr : 1 ≤ r) : + IsCoprime (cornerPoly k r) (risingPoly k r) := by + have hQ : IsCoprime (cornerPoly ℚ r) (risingPoly ℚ r) := by + rw [← Polynomial.isCoprime_map (Rat.castHom ℂ), map_cornerPoly, map_risingPoly] + exact isCoprime_corner_rising_complex hr + have := hQ.map (Polynomial.mapRingHom (Rat.castHom k)) + simpa [Polynomial.coe_mapRingHom, map_cornerPoly, map_risingPoly] using this + +/-- `C_r` is coprime to each positive integer shift of itself, over every +characteristic-zero field. -/ +theorem isCoprime_corner_shift {r : ℕ} (hr : 1 ≤ r) {n : ℕ} (hn : 1 ≤ n) : + IsCoprime (cornerPoly k r) ((cornerPoly k r).comp (X + Polynomial.C (n : k))) := by + have hQ : IsCoprime (cornerPoly ℚ r) + ((cornerPoly ℚ r).comp (X + Polynomial.C (n : ℚ))) := by + rw [← Polynomial.isCoprime_map (Rat.castHom ℂ), map_cornerPoly, Polynomial.map_comp, + map_cornerPoly] + simpa using isCoprime_corner_shift_complex hr hn + have := hQ.map (Polynomial.mapRingHom (Rat.castHom k)) + simpa [Polynomial.coe_mapRingHom, map_cornerPoly, Polynomial.map_comp] using this + +/-! ## The Bézout hypothesis of the main theorem -/ + +variable {D : Type*} + +/-- The full coprimality statement consumed by `evolution_stafford_certificate`: +`C_r` is coprime to `R₊ · ∏ⱼ C_r(X + r + j)`, for every potential support. The +shifts are `r + j ≥ r ≥ 1`, so no shifted factor meets the root line. -/ +theorem isCoprime_corner_hyper {r : ℕ} (hr : 1 ≤ r) (terms : List (D × ℕ)) : + IsCoprime (cornerPoly k r) + (risingPoly k r * shiftedProd (cornerPoly k r) (shiftSupport terms r)) := by + refine (isCoprime_corner_rising hr).mul_right ?_ + induction terms with + | nil => simpa [shiftSupport] using isCoprime_one_right (x := cornerPoly k r) + | cons t ts ih => + have hshift : IsCoprime (cornerPoly k r) + ((cornerPoly k r).comp (X + Polynomial.C ((t.2 + r : ℕ) : k))) := + isCoprime_corner_shift hr (by omega) + simpa [shiftSupport, shiftedProd_cons] using hshift.mul_right ih + +/-- **Existence of the Bézout pair.** This is exactly the hypothesis +`hbezout` of `evolution_stafford_certificate`, so the main theorem is +unconditional for every `r ≥ 1`. -/ +theorem exists_bezout {r : ℕ} (hr : 1 ≤ r) (terms : List (D × ℕ)) : + ∃ α β : k[X], cornerPoly k r * α + + (risingPoly k r * shiftedProd (cornerPoly k r) (shiftSupport terms r)) * β = 1 := by + obtain ⟨α, β, hαβ⟩ := isCoprime_corner_hyper (k := k) hr terms + exact ⟨α, β, by linear_combination hαβ⟩ + +end Stafford38.Evolution diff --git a/LeanPool/Stafford38/Stafford38/EvolutionaryCertificate.lean b/LeanPool/Stafford38/Stafford38/EvolutionaryCertificate.lean new file mode 100644 index 0000000000..da3dbb4227 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/EvolutionaryCertificate.lean @@ -0,0 +1,417 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# The evolutionary Stafford certificate + +Let `D` be a ring containing a Weyl pair `p * x - x * p = 1`, let `B` be any set +of elements commuting with both `x` and `p`, and let + + d = p ^ r - ∑ⱼ aⱼ * x ^ j, aⱼ ∈ B. + +This file machine-checks that the right ideal generated by `d` and `x ^ r * d` +is the whole ring, with the Stafford cofactor fixed to `x ^ r` independently of +`B`, of the coefficients `aⱼ`, and of the size of the support. + +The proof has three separated layers. + +* `stafford_of_bezout` is a pure ring identity: it consumes a corner + commutator, an elimination identity, and a Bézout identity, and produces the + certificate. No Weyl structure is used. +* The `Weyl` section proves the Euler shift calculus and the two factorial + identities `p ^ r * x ^ r = rising E r`, `x ^ r * p ^ r = falling E r`, where + `E = x * p`. +* `potential_elimination` performs the simultaneous shifted cancellation that + removes every potential coefficient at once. + +`evolution_stafford_certificate` assembles the three. The Bézout identity it +consumes is discharged in `Stafford38.EulerRootSeparation`, which proves the +needed polynomial coprimality under every positive integer shift. + +Convention: all ideals here are **right** ideals, matching the repository +convention. Statements are written as `d * R + x ^ r * d * S = 1`. +-/ + +namespace Stafford38.Evolution + +open Polynomial + +/-! ## Layer 1: the pure ring assembly -/ + +section Assembly + +variable {D : Type*} [Ring D] + +/-- The certificate assembly. `c` is the corner commutator `d * F - F * d`, +`h` is the eliminated polynomial, `q` the elimination cofactor, and `a`, `b` a +Bézout pair for `c` and `h`. Nothing about `D` beyond ring axioms is used. -/ +theorem stafford_of_bezout (d F c h l q a b : D) + (hcorner : d * F - F * d = c) + (helim : d * F * l = h - c * q) + (hbezout : c * a + h * b = 1) : + d * (F * a + F * (l + q) * b) + F * d * (-a - q * b) = 1 := by + have expand : + d * (F * a + F * (l + q) * b) + F * d * (-a - q * b) + = (d * F - F * d) * a + (d * F * l) * b + (d * F - F * d) * (q * b) := by + noncomm_ring + rw [expand, hcorner, helim] + have : (h - c * q) * b + c * (q * b) = h * b := by noncomm_ring + rw [show c * a + (h - c * q) * b + c * (q * b) = c * a + ((h - c * q) * b + c * (q * b)) by + noncomm_ring, this, hbezout] + +end Assembly + +/-! ## Layer 2: the Euler shift calculus -/ + +section Weyl + +variable {D : Type*} [Ring D] {x p : D} + +/-- The Euler operator. -/ +def euler (x p : D) : D := x * p + +/-- `(E + 1)(E + 2) ⋯ (E + n)`. -/ +def rising (E : D) : ℕ → D + | 0 => 1 + | (n + 1) => rising E n * (E + ((n : D) + 1)) + +/-- `E (E - 1) ⋯ (E - (n-1))`. -/ +def falling (E : D) : ℕ → D + | 0 => 1 + | (n + 1) => falling E n * (E - (n : D)) + +@[simp] lemma rising_zero (E : D) : rising E 0 = 1 := rfl +@[simp] lemma falling_zero (E : D) : falling E 0 = 1 := rfl + +lemma rising_succ (E : D) (n : ℕ) : + rising E (n + 1) = rising E n * (E + ((n : D) + 1)) := rfl + +lemma falling_succ (E : D) (n : ℕ) : + falling E (n + 1) = falling E n * (E - (n : D)) := rfl + +variable (hw : p * x = x * p + 1) + +include hw + +/-- `E * x = x * (E + 1)`. -/ +lemma euler_mul_x : euler x p * x = x * (euler x p + 1) := by + simp only [euler] + rw [mul_assoc, hw] + +/-- `E * p = p * (E - 1)`. -/ +lemma euler_mul_p : euler x p * p = p * (euler x p - 1) := by + simp only [euler] + rw [mul_sub, ← mul_assoc, hw] + noncomm_ring + +/-- `E * x ^ n = x ^ n * (E + n)`. -/ +lemma euler_mul_x_pow (n : ℕ) : + euler x p * x ^ n = x ^ n * (euler x p + (n : D)) := by + induction n with + | zero => simp + | succ n ih => + have hcast : ((n : D)) * x = x * (n : D) := (Nat.cast_commute n x).eq + rw [pow_succ, ← mul_assoc, ih, mul_assoc, add_mul, euler_mul_x hw, hcast] + push_cast + noncomm_ring + +/-- `E * p ^ n = p ^ n * (E - n)`. -/ +lemma euler_mul_p_pow (n : ℕ) : + euler x p * p ^ n = p ^ n * (euler x p - (n : D)) := by + induction n with + | zero => simp + | succ n ih => + have hcast : ((n : D)) * p = p * (n : D) := (Nat.cast_commute n p).eq + rw [pow_succ, ← mul_assoc, ih, mul_assoc, sub_mul, euler_mul_p hw, hcast] + push_cast + noncomm_ring + +/-- `E ^ m * x ^ n = x ^ n * (E + n) ^ m`. -/ +lemma euler_pow_mul_x_pow (m n : ℕ) : + euler x p ^ m * x ^ n = x ^ n * (euler x p + (n : D)) ^ m := by + induction m with + | zero => simp + | succ m ih => + rw [pow_succ, mul_assoc, euler_mul_x_pow hw, ← mul_assoc, ih, mul_assoc, ← pow_succ] + +/-- The rising factorial identity `p ^ n * x ^ n = (E+1) ⋯ (E+n)`. -/ +lemma pow_mul_pow_eq_rising (n : ℕ) : p ^ n * x ^ n = rising (euler x p) n := by + induction n with + | zero => simp + | succ n ih => + have hstep : p ^ (n + 1) * x ^ (n + 1) = p ^ n * (euler x p + 1) * x ^ n := by + rw [pow_succ, pow_succ' x n, mul_assoc, ← mul_assoc p x, hw] + simp only [euler] + noncomm_ring + rw [hstep, mul_assoc, add_mul, one_mul, euler_mul_x_pow hw, + show x ^ n * (euler x p + (n : D)) + x ^ n + = x ^ n * (euler x p + ((n : D) + 1)) by noncomm_ring, + ← mul_assoc, ih, rising_succ] + +/-- The falling factorial identity `x ^ n * p ^ n = E (E-1) ⋯ (E-(n-1))`. -/ +lemma pow_mul_pow_eq_falling (n : ℕ) : x ^ n * p ^ n = falling (euler x p) n := by + induction n with + | zero => simp + | succ n ih => + have hstep : x ^ (n + 1) * p ^ (n + 1) = x ^ n * euler x p * p ^ n := by + rw [pow_succ x n, pow_succ' p n, mul_assoc] + simp only [euler] + noncomm_ring + rw [hstep, mul_assoc, euler_mul_p_pow hw, ← mul_assoc, ih, falling_succ] + +end Weyl + +section Elimination + +variable {D : Type*} [Ring D] {x p : D} + +/-! ### Polynomial shift calculus -/ + +variable {k : Type*} [CommRing k] [Algebra k D] + +/-- `f(E) * x ^ n = x ^ n * f(E + n)` for every polynomial `f`. -/ +lemma aeval_euler_mul_x_pow (hw : p * x = x * p + 1) (n : ℕ) (f : k[X]) : + aeval (euler x p) f * x ^ n = x ^ n * aeval (euler x p + (n : D)) f := by + induction f using Polynomial.induction_on' with + | add f g hf hg => simp only [map_add, add_mul, mul_add, hf, hg] + | monomial m a => + simp only [aeval_monomial] + rw [mul_assoc, euler_pow_mul_x_pow hw, ← mul_assoc, ← mul_assoc, + (Algebra.commutes a (x ^ n)).symm] + +/-- An element commuting with `E` commutes with every polynomial in `E`. -/ +lemma commute_aeval_euler {a E : D} (h : a * E = E * a) (f : k[X]) : + a * aeval E f = aeval E f * a := by + have hc : Commute a E := h + induction f using Polynomial.induction_on' with + | add f g hf hg => simp only [map_add, mul_add, add_mul, hf, hg] + | monomial m b => + simp only [aeval_monomial] + have c1 : Commute a (algebraMap k D b) := (Algebra.commutes b a).symm + exact (c1.mul_right (hc.pow_right m)).eq + +/-- The rising factorial as a polynomial. -/ +noncomputable def risingPoly (k : Type*) [CommRing k] : ℕ → k[X] + | 0 => 1 + | (n + 1) => risingPoly k n * (X + Polynomial.C ((n : k) + 1)) + +/-- The falling factorial as a polynomial. -/ +noncomputable def fallingPoly (k : Type*) [CommRing k] : ℕ → k[X] + | 0 => 1 + | (n + 1) => fallingPoly k n * (X - Polynomial.C (n : k)) + +/-- The Euler corner polynomial `C_r = R₊ - R₋`; its evaluation at `E` is the +commutator `p ^ r x ^ r - x ^ r p ^ r`. -/ +noncomputable def cornerPoly (k : Type*) [CommRing k] (r : ℕ) : k[X] := + risingPoly k r - fallingPoly k r + +@[simp] lemma risingPoly_zero : risingPoly k 0 = 1 := rfl + +lemma risingPoly_succ (n : ℕ) : + risingPoly k (n + 1) = risingPoly k n * (X + Polynomial.C ((n : k) + 1)) := rfl + +@[simp] lemma fallingPoly_zero : fallingPoly k 0 = 1 := rfl + +lemma fallingPoly_succ (n : ℕ) : + fallingPoly k (n + 1) = fallingPoly k n * (X - Polynomial.C (n : k)) := rfl + +lemma aeval_risingPoly (E : D) (n : ℕ) : + aeval E (risingPoly k n) = rising E n := by + induction n with + | zero => simp [risingPoly_zero] + | succ n ih => simp [risingPoly_succ, rising_succ, ih] + +lemma aeval_fallingPoly (E : D) (n : ℕ) : + aeval E (fallingPoly k n) = falling E n := by + induction n with + | zero => simp [fallingPoly_zero] + | succ n ih => simp [fallingPoly_succ, falling_succ, ih] + +lemma aeval_cornerPoly (E : D) (r : ℕ) : + aeval E (cornerPoly k r) = rising E r - falling E r := by + simp [cornerPoly, aeval_risingPoly, aeval_fallingPoly] + +/-! ### Simultaneous elimination of every potential coefficient -/ + +/-- `∑ⱼ aⱼ * x ^ nⱼ`, the potential written in the given support. -/ +def potentialSum (x : D) : List (D × ℕ) → D + | [] => 0 + | (t :: ts) => t.1 * x ^ t.2 + potentialSum x ts + +/-- `∏ⱼ C(X + nⱼ)`, one shift of the corner polynomial per potential term. -/ +noncomputable def shiftedProd (C : k[X]) : List (D × ℕ) → k[X] + | [] => 1 + | (t :: ts) => C.comp (X + Polynomial.C ((t.2 : ℕ) : k)) * shiftedProd C ts + +omit [Ring D] [Algebra k D] in +@[simp] lemma shiftedProd_nil (C : k[X]) : shiftedProd C ([] : List (D × ℕ)) = 1 := rfl + +omit [Ring D] [Algebra k D] in +lemma shiftedProd_cons (C : k[X]) (t : D × ℕ) (ts : List (D × ℕ)) : + shiftedProd C (t :: ts) + = C.comp (X + Polynomial.C ((t.2 : ℕ) : k)) * shiftedProd C ts := rfl + +lemma aeval_comp_shift (E : D) (C : k[X]) (n : ℕ) : + aeval E (C.comp (X + Polynomial.C ((n : ℕ) : k))) = aeval (E + (n : D)) C := by + simp [aeval_comp] + +/-- **Simultaneous shifted cancellation.** Multiplying the potential on the +right by one shift of the corner polynomial per term turns the whole potential +into a left multiple of the corner polynomial. Every coefficient is eliminated +at once, and the coefficients are never assumed to commute with one another. -/ +theorem potential_elimination (hw : p * x = x * p + 1) (C : k[X]) + (terms : List (D × ℕ)) (hcomm : ∀ t ∈ terms, t.1 * euler x p = euler x p * t.1) : + ∃ q : D, potentialSum x terms * aeval (euler x p) (shiftedProd C terms) + = aeval (euler x p) C * q := by + induction terms with + | nil => exact ⟨0, by simp [potentialSum, shiftedProd]⟩ + | cons t ts ih => + obtain ⟨q, hq⟩ := ih fun s hs => hcomm s (List.mem_cons_of_mem _ hs) + have ht : t.1 * euler x p = euler x p * t.1 := hcomm t List.mem_cons_self + set E := euler x p with hE + set Cs : k[X] := C.comp (X + Polynomial.C ((t.2 : ℕ) : k)) with hCs + set L : k[X] := shiftedProd C ts with hL + -- the key exchange: `x ^ n * C(E + n) = C(E) * x ^ n` + have hswap : x ^ t.2 * aeval E Cs = aeval E C * x ^ t.2 := by + rw [hCs, aeval_comp_shift, ← aeval_euler_mul_x_pow hw] + refine ⟨t.1 * x ^ t.2 * aeval E L + q * aeval E Cs, ?_⟩ + have hprod : shiftedProd C (t :: ts) = Cs * L := rfl + rw [potentialSum, hprod, map_mul, add_mul, mul_add] + congr 1 + · calc t.1 * x ^ t.2 * (aeval E Cs * aeval E L) + = t.1 * (x ^ t.2 * aeval E Cs) * aeval E L := by noncomm_ring + _ = t.1 * (aeval E C * x ^ t.2) * aeval E L := by rw [hswap] + _ = (t.1 * aeval E C) * (x ^ t.2 * aeval E L) := by noncomm_ring + _ = aeval E C * (t.1 * x ^ t.2 * aeval E L) := by + rw [commute_aeval_euler ht C]; noncomm_ring + · calc potentialSum x ts * (aeval E Cs * aeval E L) + = potentialSum x ts * (aeval E L * aeval E Cs) := by + rw [← map_mul, ← map_mul, mul_comm] + _ = (potentialSum x ts * aeval E L) * aeval E Cs := by noncomm_ring + _ = aeval E C * q * aeval E Cs := by rw [hq] + _ = aeval E C * (q * aeval E Cs) := by noncomm_ring + +/-! ### The main theorem -/ + +/-- Shifting every exponent of the potential support by `r`. -/ +def shiftSupport (terms : List (D × ℕ)) (r : ℕ) : List (D × ℕ) := + terms.map fun t => (t.1, t.2 + r) + +lemma potentialSum_mul_pow (x : D) (terms : List (D × ℕ)) (r : ℕ) : + potentialSum x terms * x ^ r = potentialSum x (shiftSupport terms r) := by + induction terms with + | nil => simp [potentialSum, shiftSupport] + | cons t ts ih => + simp only [shiftSupport, List.map_cons, potentialSum, add_mul] + rw [mul_assoc, ← pow_add] + congr 1 + +lemma commute_potentialSum_x {terms : List (D × ℕ)} + (h : ∀ t ∈ terms, t.1 * x = x * t.1) : + potentialSum x terms * x = x * potentialSum x terms := by + induction terms with + | nil => simp [potentialSum] + | cons t ts ih => + have ht := h t List.mem_cons_self + rw [potentialSum, add_mul, mul_add, ih fun s hs => h s (List.mem_cons_of_mem _ hs)] + congr 1 + calc t.1 * x ^ t.2 * x = t.1 * x * x ^ t.2 := by rw [mul_assoc, mul_assoc, ← pow_succ, + ← pow_succ'] + _ = x * (t.1 * x ^ t.2) := by rw [ht, mul_assoc] + +lemma commute_potentialSum_x_pow {terms : List (D × ℕ)} + (h : ∀ t ∈ terms, t.1 * x = x * t.1) (r : ℕ) : + potentialSum x terms * x ^ r = x ^ r * potentialSum x terms := by + induction r with + | zero => simp + | succ r ih => + rw [pow_succ, ← mul_assoc, ih, mul_assoc, commute_potentialSum_x h, ← mul_assoc] + +/-- **Aggregate-commutation evolutionary Stafford theorem.** + +Let `D` be any ring carrying a Weyl pair `p * x - x * p = 1`, let the potential +`A = ∑ⱼ aⱼ * x ^ j` be a displayed finite potential. Assume directly that +the shifted coefficients commute with the Euler operator and that the +aggregate potential commutes with `x ^ r`; no coefficientwise commutation with +`x` or `p` is required. Put + + d = p ^ r - A. + +Given a Bézout identity for the corner polynomial `C_r` against +`R₊ · ∏ⱼ C_r(X + r + j)` (supplied by `Stafford38.EulerRootSeparation`), the right ideal +generated by `d` and `x ^ r * d` is the whole ring, with the explicit +certificate below. -/ +theorem evolution_stafford_certificate_of_aggregate_commutation + (hw : p * x = x * p + 1) (r : ℕ) (terms : List (D × ℕ)) + (hcommE : ∀ t ∈ shiftSupport terms r, + t.1 * euler x p = euler x p * t.1) + (hAxr : potentialSum x terms * x ^ r = + x ^ r * potentialSum x terms) + (α β : k[X]) + (hbezout : cornerPoly k r * α + + (risingPoly k r * shiftedProd (cornerPoly k r) (shiftSupport terms r)) * β = 1) : + ∃ R S : D, (p ^ r - potentialSum x terms) * R + + x ^ r * (p ^ r - potentialSum x terms) * S = 1 := by + set E := euler x p with hE + set A := potentialSum x terms with hA + set d := p ^ r - A with hd + set C : k[X] := cornerPoly k r with hC + set L : k[X] := shiftedProd C (shiftSupport terms r) with hL + have hcommE' : ∀ t ∈ shiftSupport terms r, t.1 * E = E * t.1 := by + simpa [hE] using hcommE + -- the corner commutator + have hcorner : d * x ^ r - x ^ r * d = aeval E C := by + rw [hd, sub_mul, mul_sub, hAxr, aeval_cornerPoly, pow_mul_pow_eq_rising hw, + pow_mul_pow_eq_falling hw] + abel + -- simultaneous elimination + obtain ⟨q, hq⟩ := potential_elimination hw C (shiftSupport terms r) hcommE' + have helim : d * x ^ r * aeval E L + = aeval E (risingPoly k r * L) - aeval E C * q := by + have hAxr : A * x ^ r = potentialSum x (shiftSupport terms r) := + potentialSum_mul_pow x terms r + rw [hd, sub_mul, hAxr, pow_mul_pow_eq_rising hw, sub_mul, hq, map_mul, + aeval_risingPoly] + -- Bézout, transported into `D` + have hbez : aeval E C * aeval E α + aeval E (risingPoly k r * L) * aeval E β = 1 := by + have := congrArg (aeval (R := k) E) hbezout + simpa [map_add, map_mul] using this + exact ⟨_, _, stafford_of_bezout d (x ^ r) (aeval E C) (aeval E (risingPoly k r * L)) + (aeval E L) q (aeval E α) (aeval E β) hcorner helim hbez⟩ + +/-! The original coefficientwise theorem is a corollary of the aggregate +interface. Keeping it explicit preserves the existing API while exposing +the strictly weaker hypotheses as a reusable producer contract. -/ +theorem evolution_stafford_certificate + (hw : p * x = x * p + 1) (r : ℕ) (terms : List (D × ℕ)) + (hx : ∀ t ∈ terms, t.1 * x = x * t.1) + (hp : ∀ t ∈ terms, t.1 * p = p * t.1) + (α β : k[X]) + (hbezout : cornerPoly k r * α + + (risingPoly k r * shiftedProd (cornerPoly k r) (shiftSupport terms r)) * β = 1) : + ∃ R S : D, (p ^ r - potentialSum x terms) * R + + x ^ r * (p ^ r - potentialSum x terms) * S = 1 := by + have hcommE : ∀ t ∈ shiftSupport terms r, + t.1 * euler x p = euler x p * t.1 := by + rintro ⟨a, n⟩ hmem + simp only [shiftSupport, List.mem_map] at hmem + obtain ⟨⟨b, m⟩, hb, heq⟩ := hmem + have hba : b = a := congrArg Prod.fst heq + subst hba + have h1 : b * x = x * b := hx _ hb + have h2 : b * p = p * b := hp _ hb + simp only [euler] + rw [← mul_assoc, h1, mul_assoc, h2, mul_assoc] + have hAxr : potentialSum x terms * x ^ r = + x ^ r * potentialSum x terms := commute_potentialSum_x_pow hx r + exact evolution_stafford_certificate_of_aggregate_commutation + hw r terms hcommE hAxr α β hbezout + +end Elimination + +end Stafford38.Evolution diff --git a/LeanPool/Stafford38/Stafford38/EvolutionaryCorollary.lean b/LeanPool/Stafford38/Stafford38/EvolutionaryCorollary.lean new file mode 100644 index 0000000000..1be4a945e9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/EvolutionaryCorollary.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.EvolutionaryCertificate +import LeanPool.Stafford38.Stafford38.EulerRootSeparation +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence + +/-! +# Evolutionary Stafford corollary + +This file combines the algebraic certificate with Euler-root separation. It +contains only the unconditional ring-theoretic corollary needed by the paper. +-/ + +namespace Stafford38.Evolution + +open scoped TensorProduct +open Stafford38.WeylIteratedEquivalence + +variable {D : Type*} [Ring D] {x p : D} + +/-- For a Weyl pair and a finite polynomial potential whose coefficients +commute separately with both generators, the two displayed right multiples +give a Stafford certificate with fixed left source `x ^ r`. -/ +theorem evolution_stafford (k : Type*) [Field k] [CharZero k] [Algebra k D] + (hw : p * x = x * p + 1) {r : ℕ} (hr : 0 < r) (terms : List (D × ℕ)) + (hx : ∀ t ∈ terms, t.1 * x = x * t.1) + (hp : ∀ t ∈ terms, t.1 * p = p * t.1) : + ∃ R S : D, (p ^ r - potentialSum x terms) * R + + x ^ r * (p ^ r - potentialSum x terms) * S = 1 := by + obtain ⟨α, β, hαβ⟩ := exists_bezout (k := k) (D := D) hr terms + exact evolution_stafford_certificate hw r terms hx hp α β hαβ + +/-- Exact paper-facing form. No commutativity among the coefficients is +assumed: each displayed coefficient need only commute with `x` and `p`. -/ +theorem evolutionaryCorollary (k : Type*) [Field k] [CharZero k] [Algebra k D] + (hw : p * x = x * p + 1) {r : ℕ} (hr : 0 < r) (terms : List (D × ℕ)) + (hx : ∀ t ∈ terms, t.1 * x = x * t.1) + (hp : ∀ t ∈ terms, t.1 * p = p * t.1) + {d : D} (hd : d = p ^ r - potentialSum x terms) : + ∃ R S : D, 1 = d * R + x ^ r * d * S := by + obtain ⟨R, S, h⟩ := evolution_stafford k hw hr terms hx hp + exact ⟨R, S, by simpa [hd] using h.symm⟩ + +section TensorProduct + +variable (k B : Type*) [Field k] [CharZero k] [Ring B] [Algebra k B] + +local notation "W₁" => PresentedWeyl k 1 +local notation "Dᵣ" => B ⊗[k] W₁ +local notation "ιB" => (Algebra.TensorProduct.includeLeft : B →ₐ[k] Dᵣ) +local notation "ιW" => (Algebra.TensorProduct.includeRight : W₁ →ₐ[k] Dᵣ) + +/-- The evolutionary certificate in the literal tensor algebra +`B ⊗[k] A₁(k)`. This asserts no identification with a geometric ring of +differential operators. -/ +theorem tensorEvolutionaryCorollary {r : ℕ} (hr : 0 < r) + (terms : List (B × ℕ)) {d : Dᵣ} + (hd : d = ιW (presentedMomentum k 0) ^ r - + potentialSum (ιW (presentedCoordinate k 0)) + (terms.map fun t => (ιB t.1, t.2))) : + ∃ R S : Dᵣ, 1 = d * R + ιW (presentedCoordinate k 0) ^ r * d * S := by + let lifted : List (Dᵣ × ℕ) := terms.map fun t => (ιB t.1, t.2) + have hcomm : ∀ (b : B) (w : W₁), ιB b * ιW w = ιW w * ιB b := by + intro b w + simp [Algebra.TensorProduct.includeLeft_apply, + Algebra.TensorProduct.includeRight_apply, + Algebra.TensorProduct.tmul_mul_tmul] + have hx : ∀ t ∈ lifted, + t.1 * ιW (presentedCoordinate k 0) = + ιW (presentedCoordinate k 0) * t.1 := by + rintro t ht + rcases List.mem_map.mp ht with ⟨⟨b, n⟩, _, rfl⟩ + exact hcomm b (presentedCoordinate k 0) + have hp : ∀ t ∈ lifted, + t.1 * ιW (presentedMomentum k 0) = + ιW (presentedMomentum k 0) * t.1 := by + rintro t ht + rcases List.mem_map.mp ht with ⟨⟨b, n⟩, _, rfl⟩ + exact hcomm b (presentedMomentum k 0) + have hw : ιW (presentedMomentum k 0) * ιW (presentedCoordinate k 0) = + ιW (presentedCoordinate k 0) * ιW (presentedMomentum k 0) + 1 := by + calc + _ = ιW (presentedMomentum k 0 * presentedCoordinate k 0) := + (map_mul ιW _ _).symm + _ = ιW (presentedCoordinate k 0 * presentedMomentum k 0 + 1) := + congrArg ιW (presentedMomentum_mul_coordinate k 0) + _ = _ := by rw [map_add, map_mul, map_one] + exact evolutionaryCorollary + (D := Dᵣ) (x := ιW (presentedCoordinate k 0)) + (p := ιW (presentedMomentum k 0)) k hw hr lifted hx hp hd + +end TensorProduct + +end Stafford38.Evolution diff --git a/LeanPool/Stafford38/Stafford38/FixedSourceAssembly.lean b/LeanPool/Stafford38/Stafford38/FixedSourceAssembly.lean new file mode 100644 index 0000000000..38f9064f87 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/FixedSourceAssembly.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.FixedSourceStatement + +namespace Stafford38.FixedSource + +open Stafford38 +open Stafford38.UniversalAssembly +open Stafford38.CharacteristicCanonicalCertificate +open Stafford38.CharacteristicInitialIdeal +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylMonicNormalization +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylSymplectic +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylFiltration +open Stafford + +noncomputable section +universe u + +theorem universalFixedSourceStatement_of_canonicalSupportVanishing + (hvanish : CanonicalSupportVanishing.{u}) : + UniversalFixedSourceStatement.{u} := by + intro k _ _ n d hd + rcases exists_top_bernstein_piece k hd with ⟨N, hpiece, hprincipal⟩ + have hdegree : bernsteinDegree k d = N := + bernsteinDegree_eq_of_piece_of_principal_ne_zero k hpiece hprincipal + by_cases hNzero : N = 0 + · have hpiece0 : d ∈ bernsteinPiece k (n + 1) 0 := by + simpa [hNzero] using hpiece + rcases eq_algebraMap_of_mem_bernsteinPiece_zero k hpiece0 with ⟨c, rfl⟩ + have hc : c ≠ 0 := by + intro hc + subst c + simp at hd + let ell : PresentedWeyl k (n + 1) := presentedCoordinate k n + have hell : IsLinearWeylCoordinate k n ell := by + refine ⟨1, 1, ?_, ?_, ?_, ?_, ?_⟩ + · simp + · simp + · simp + · simp + · change freeWeylGenerator (standardForm k (n + 1)) + (.inl (0 : Fin (n + 1))) = + freeWeylLinearCombination 1 + (freeWeylGenerator (standardForm k (n + 1))) + (.inl (0 : Fin (n + 1))) + exact (freeWeylLinearCombination_one (standardForm k (n + 1)) + (.inl (0 : Fin (n + 1)))).symm + + refine ⟨ell, algebraMap k _ c⁻¹, 0, hell, ?_⟩ + simp only [hdegree, hNzero, pow_zero] + rw [← map_mul, mul_inv_cancel₀ hc, map_one] + simp + · have hN : 0 < N := Nat.pos_of_ne_zero hNzero + rcases exists_normalized_symplectic_image k + (.inr ⟨0, Nat.succ_pos n⟩) hpiece (principal_isHomogeneous k d) + hprincipal hN with + ⟨M, Ninv, c, hM, hNinv, hMN, hNM, hc, hpiece', haxis⟩ + let e := standardSymplecticAlgEquivOfInverse k M Ninv hM hNinv hMN hNM + let d' : PresentedWeyl k (n + 1) := normalizedSymplecticImage k M hM c d + have hd' : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d' := by + refine ⟨hpiece', ?_⟩ + rw [← coeff_principal_pure_eq_normalForm k] + rw [← coeff_axisPolynomial k] + exact haxis + have hsupp := hvanish k n N d' hN hd' + rcases exists_fixedSource_certificate_of_orderCharacteristicSupport_eq_empty + k n N d' hsupp with ⟨R, S, hcert⟩ + let a : PresentedWeyl k (n + 1) := algebraMap k _ c⁻¹ + have hd'eq : d' = a * e d := by + simp [d', a, e, normalizedSymplecticImage, Algebra.smul_def, + standardSymplecticAlgEquivOfInverse] + all_goals rfl + have ha_comm : ∀ z : PresentedWeyl k (n + 1), a * z = z * a := by + intro z + exact Algebra.commutes c⁻¹ z + have hchartCert : + (1 : PresentedWeyl k (n + 1)) = e d * (a * R) + + (presentedCoordinate k n) ^ N * e d * (a * S) := by + rw [hcert, hd'eq] + rw [ha_comm (e d)] + simp only [mul_assoc] + let ell : PresentedWeyl k (n + 1) := e.symm (presentedCoordinate k n) + have hell : IsLinearWeylCoordinate k n ell := by + refine ⟨M, Ninv, hM, hNinv, hMN, hNM, ?_⟩ + change (standardSymplecticAlgEquivOfInverse k M Ninv hM hNinv hMN hNM).symm + (freeWeylGenerator (standardForm k (n + 1)) + (.inl (0 : Fin (n + 1)))) = + freeWeylLinearCombination Ninv + (freeWeylGenerator (standardForm k (n + 1))) + (.inl (0 : Fin (n + 1))) + exact standardSymplecticAlgEquivOfInverse_symm_generator + k M Ninv hM hNinv hMN hNM (.inl (0 : Fin (n + 1))) + refine ⟨ell, e.symm (a * R), e.symm (a * S), hell, ?_⟩ + have ht := congrArg e.symm hchartCert + simpa [ell, hdegree] using ht + +/-- Pointwise form of the exact-degree fixed-source theorem. -/ +theorem fixedSource_positive + (hvanish : CanonicalSupportVanishing.{u}) + (k : Type u) [Field k] [CharZero k] (n : ℕ) + (d : PresentedWeyl k (n + 1)) (hd : d ≠ 0) : + ∃ ell R S : PresentedWeyl k (n + 1), + IsLinearWeylCoordinate k n ell ∧ + (1 : PresentedWeyl k (n + 1)) = + d * R + ell ^ bernsteinDegree k d * d * S := + universalFixedSourceStatement_of_canonicalSupportVanishing hvanish k n d hd + + +end +end Stafford38.FixedSource diff --git a/LeanPool/Stafford38/Stafford38/FixedSourceChallengeTransport.lean b/LeanPool/Stafford38/Stafford38/FixedSourceChallengeTransport.lean new file mode 100644 index 0000000000..0734e50d0e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/FixedSourceChallengeTransport.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.FixedSourceStatement +import Mathlib.Order.Lattice.Nat + +/-! +# Transport for the Mathlib-only exact-source challenge + +`FixedSourceChallenge.lean` states the exact fixed-source theorem using only +Mathlib: the Weyl algebra is the `RingQuot` of the free algebra by the Weyl +commutator relation, the Bernstein filtration is the span of the images of the +ordered PBW words of bounded total degree, and the Bernstein degree of an +element is the least filtration level containing it. + +This file repeats those definitions verbatim in the namespace +`Stafford38FixedSourceChallenge`, without importing the challenge file, and +proves that they agree with the substantive development: + +* the challenge quotient is definitionally the presented Weyl algebra + `Stafford38.WeylIteratedEquivalence.PresentedWeyl`; +* the challenge ordered words are the development's + `Stafford38.WeylPBW.presentedOrderedMonomial`; +* the challenge filtration is the development's Bernstein filtration + `Stafford38.WeylFiltration.bernsteinPiece`; +* the challenge degree is the development's checked PBW normal-form degree + `Stafford38.FixedSource.bernsteinDegree`; +* the two linear-coordinate predicates are definitionally the same. + +`FixedSourceSolution.lean` combines these identifications with the proved +theorem `Stafford38.universalFixedSourceStatement`. No degree and no +normal-form datum is supplied as a hypothesis anywhere. +-/ + +namespace Stafford38FixedSourceChallenge + +universe u + +abbrev PhaseVar (n : ℕ) := Fin n ⊕ Fin n + +def relation {k : Type u} [Field k] {n : ℕ} + (omega : Matrix (PhaseVar n) (PhaseVar n) k) + (a b : FreeAlgebra k (PhaseVar n)) : Prop := + ∃ i j, + a = FreeAlgebra.ι k i * FreeAlgebra.ι k j - + FreeAlgebra.ι k j * FreeAlgebra.ι k i ∧ + b = algebraMap k (FreeAlgebra k (PhaseVar n)) (omega i j) + +abbrev WeylAlg (k : Type u) [Field k] (n : ℕ) := + RingQuot (relation (k := k) (n := n) (Matrix.J (Fin n) k)) + +def generator (k : Type u) [Field k] (n : ℕ) (i : PhaseVar n) : WeylAlg k n := + RingQuot.mkAlgHom k (relation (k := k) (n := n) (Matrix.J (Fin n) k)) + (FreeAlgebra.ι k i) + +def oldIndex {n : ℕ} : PhaseVar n → PhaseVar (n + 1) + | .inl i => .inl i.succ + | .inr i => .inr i.succ + +def freeOldMap (k : Type u) [Field k] (n : ℕ) : + FreeAlgebra k (PhaseVar n) →ₐ[k] FreeAlgebra k (PhaseVar (n + 1)) := + FreeAlgebra.lift k (fun i => FreeAlgebra.ι k (oldIndex i)) + +def freeOrderedMonomial (k : Type u) [Field k] : + (n : ℕ) → (Fin n → ℕ) → (Fin n → ℕ) → FreeAlgebra k (PhaseVar n) + | 0, _, _ => 1 + | n + 1, a, p => + freeOldMap k n + (freeOrderedMonomial k n (fun i => a i.succ) (fun i => p i.succ)) * + FreeAlgebra.ι k (.inl (0 : Fin (n + 1))) ^ a 0 * + FreeAlgebra.ι k (.inr (0 : Fin (n + 1))) ^ p 0 + +def orderedMonomial (k : Type u) [Field k] (n : ℕ) + (a p : Fin n → ℕ) : WeylAlg k n := + RingQuot.mkAlgHom k (relation (k := k) (n := n) (Matrix.J (Fin n) k)) + (freeOrderedMonomial k n a p) + +def phaseDegree {n : ℕ} (a p : Fin n → ℕ) : ℕ := + (∑ i, a i) + ∑ i, p i + +def bernsteinPiece (k : Type u) [Field k] (n N : ℕ) : + Submodule k (WeylAlg k n) := + Submodule.span k + {z | ∃ a p : Fin n → ℕ, + phaseDegree a p ≤ N ∧ z = orderedMonomial k n a p} + +noncomputable def bernsteinDegree (k : Type u) [Field k] {n : ℕ} + (d : WeylAlg k n) : ℕ := + sInf {N : ℕ | d ∈ bernsteinPiece k n N} + +def linearCombination (k : Type u) [Field k] {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (z : PhaseVar n → WeylAlg k n) (i : PhaseVar n) : WeylAlg k n := + ∑ j, algebraMap k (WeylAlg k n) (M i j) * z j + +abbrev standardForm (k : Type u) [Field k] (n : ℕ) : + Matrix (PhaseVar n) (PhaseVar n) k := Matrix.J (Fin n) k + +def IsLinearWeylCoordinate (k : Type u) [Field k] (n : ℕ) + (ell : WeylAlg k (n + 1)) : Prop := + ∃ (M N : Matrix (PhaseVar (n + 1)) (PhaseVar (n + 1)) k) + (_hM : M * standardForm k (n + 1) * Matrix.transpose M = + standardForm k (n + 1)) + (_hN : N * standardForm k (n + 1) * Matrix.transpose N = + standardForm k (n + 1)) + (_hMN : M * N = 1) (_hNM : N * M = 1), + ell = linearCombination k N (generator k (n + 1)) + (.inl (0 : Fin (n + 1))) + +def UniversalFixedSourceStatement : Prop := + ∀ (k : Type u) [Field k] [CharZero k] (n : ℕ) + (d : WeylAlg k (n + 1)), d ≠ 0 → + ∃ ell R S : WeylAlg k (n + 1), + IsLinearWeylCoordinate k n ell ∧ + (1 : WeylAlg k (n + 1)) = + d * R + ell ^ bernsteinDegree k d * d * S + +end Stafford38FixedSourceChallenge + +namespace Stafford38FixedSourceChallengeTransport + +open Stafford +open Stafford38.WeylPBW +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence + +universe u + +variable (k : Type u) [Field k] + +/-- The challenge quotient is the presented Weyl algebra, definitionally. -/ +theorem weylAlg_eq (n : ℕ) : + Stafford38FixedSourceChallenge.WeylAlg k n = PresentedWeyl k n := rfl + +/-- The challenge generators are the presented generators, definitionally. -/ +theorem generator_eq (n : ℕ) (i : Stafford38FixedSourceChallenge.PhaseVar n) : + Stafford38FixedSourceChallenge.generator k n i = + freeWeylGenerator (Matrix.J (Fin n) k) i := rfl + +theorem oldIndex_eq {n : ℕ} (i : Stafford38FixedSourceChallenge.PhaseVar n) : + Stafford38FixedSourceChallenge.oldIndex i = + Stafford38.WeylIteratedEquivalence.oldIndex i := by + cases i <;> rfl + +/-- Inserting an old free word and passing to the quotient agrees with the +development's rank-shift embedding of the old quotient. -/ +theorem mkAlgHom_freeOldMap (n : ℕ) + (x : FreeAlgebra k (Stafford38FixedSourceChallenge.PhaseVar n)) : + RingQuot.mkAlgHom k + (Stafford38FixedSourceChallenge.relation (k := k) (n := n + 1) + (Matrix.J (Fin (n + 1)) k)) + (Stafford38FixedSourceChallenge.freeOldMap k n x) = + previousWeylEmbedding k n + (RingQuot.mkAlgHom k + (Stafford38FixedSourceChallenge.relation (k := k) (n := n) + (Matrix.J (Fin n) k)) x) := by + have h : + (RingQuot.mkAlgHom k + (Stafford38FixedSourceChallenge.relation (k := k) (n := n + 1) + (Matrix.J (Fin (n + 1)) k))).comp + (Stafford38FixedSourceChallenge.freeOldMap k n) = + (previousWeylEmbedding k n).comp + (RingQuot.mkAlgHom k + (Stafford38FixedSourceChallenge.relation (k := k) (n := n) + (Matrix.J (Fin n) k))) := by + apply FreeAlgebra.hom_ext + funext i + simp only [Function.comp_apply, AlgHom.comp_apply, + Stafford38FixedSourceChallenge.freeOldMap, FreeAlgebra.lift_ι_apply] + change freeWeylGenerator (Matrix.J (Fin (n + 1)) k) + (Stafford38FixedSourceChallenge.oldIndex i) = + previousWeylEmbedding k n (freeWeylGenerator (Matrix.J (Fin n) k) i) + rw [previousWeylEmbedding_generator, oldIndex_eq] + rfl + exact DFunLike.congr_fun h x + +/-- The challenge ordered words are the development's ordered PBW words. -/ +theorem orderedMonomial_eq : + ∀ (n : ℕ) (a p : Fin n → ℕ), + Stafford38FixedSourceChallenge.orderedMonomial k n a p = + presentedOrderedMonomial k n a p := by + intro n + induction n with + | zero => + intro a p + simp only [Stafford38FixedSourceChallenge.orderedMonomial, + Stafford38FixedSourceChallenge.freeOrderedMonomial, + presentedOrderedMonomial, map_one] + rfl + | succ n ih => + intro a p + have htail := ih (fun i => a i.succ) (fun i => p i.succ) + rw [Stafford38FixedSourceChallenge.orderedMonomial] at htail + simp only [Stafford38FixedSourceChallenge.orderedMonomial, + Stafford38FixedSourceChallenge.freeOrderedMonomial, map_mul, map_pow, + presentedOrderedMonomial] + rw [mkAlgHom_freeOldMap, htail] + rfl + +/-- The Bernstein weight of a split exponent is the challenge's total phase +degree. -/ +theorem monomialWeight_bernstein_phaseExponent {n : ℕ} (a p : Fin n → ℕ) : + monomialWeight (@bernsteinWeight n) (phaseExponent a p) = + Stafford38FixedSourceChallenge.phaseDegree a p := by + unfold monomialWeight bernsteinWeight Stafford38FixedSourceChallenge.phaseDegree + rw [Finsupp.sum_fintype _ _ (fun _ => by simp)] + simp [Fintype.sum_sum_type] + +/-- The challenge filtration is the development's Bernstein filtration. -/ +theorem bernsteinPiece_eq (n N : ℕ) : + Stafford38FixedSourceChallenge.bernsteinPiece k n N = + Stafford38.WeylFiltration.bernsteinPiece k n N := by + rw [Stafford38FixedSourceChallenge.bernsteinPiece, + Stafford38.WeylFiltration.bernsteinPiece, presentedWeightPiece_eq_span] + congr 1 + ext z + simp only [presentedWeightBasisSet, Set.mem_ofPred_eq] + constructor + · rintro ⟨a, p, hdeg, rfl⟩ + refine ⟨phaseExponent a p, ?_, ?_⟩ + · rw [monomialWeight_bernstein_phaseExponent] + exact hdeg + · rw [presentedPBWBasis_apply, orderedMonomial_eq] + rfl + · rintro ⟨m, hdeg, rfl⟩ + refine ⟨fun i => m (.inl i), fun i => m (.inr i), ?_, ?_⟩ + · rw [← monomialWeight_bernstein_phaseExponent, phaseExponent_split] + exact hdeg + · rw [presentedPBWBasis_apply, orderedMonomial_eq] + +/-- The challenge's intrinsic degree is the development's checked PBW +normal-form degree. -/ +theorem bernsteinDegree_eq {n : ℕ} (d : PresentedWeyl k n) : + Stafford38FixedSourceChallenge.bernsteinDegree k d = + Stafford38.FixedSource.bernsteinDegree k d := by + have hmem' : d ∈ presentedWeightPiece k (@bernsteinWeight n) + (Stafford38.FixedSource.bernsteinDegree k d) := + (mem_presentedWeightPiece k _ _ d).mpr fun m hm => + MvPolynomial.le_weightedTotalDegree _ + (MvPolynomial.mem_support_iff.mpr hm) + have hmem : d ∈ Stafford38FixedSourceChallenge.bernsteinPiece k n + (Stafford38.FixedSource.bernsteinDegree k d) := by + rw [bernsteinPiece_eq] + exact hmem' + have hle : ∀ N, d ∈ Stafford38FixedSourceChallenge.bernsteinPiece k n N → + Stafford38.FixedSource.bernsteinDegree k d ≤ N := by + intro N hN + rw [bernsteinPiece_eq] at hN + have hN' : d ∈ presentedWeightPiece k (@bernsteinWeight n) N := hN + rw [mem_presentedWeightPiece] at hN' + apply Finset.sup_le + intro m hm + exact hN' m (MvPolynomial.mem_support_iff.mp hm) + apply le_antisymm + · exact Nat.sInf_le hmem + · exact le_csInf ⟨_, hmem⟩ hle + +/-- The two linear symplectic coordinate predicates are definitionally the +same. -/ +theorem isLinearWeylCoordinate_iff (n : ℕ) + (ell : Stafford38FixedSourceChallenge.WeylAlg k (n + 1)) : + Stafford38FixedSourceChallenge.IsLinearWeylCoordinate k n ell ↔ + Stafford38.FixedSource.IsLinearWeylCoordinate k n ell := + Iff.rfl + + +end Stafford38FixedSourceChallengeTransport diff --git a/LeanPool/Stafford38/Stafford38/FixedSourceStatement.lean b/LeanPool/Stafford38/Stafford38/FixedSourceStatement.lean new file mode 100644 index 0000000000..6542a172c6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/FixedSourceStatement.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.UniversalAssembly + +namespace Stafford38.FixedSource + +open Stafford38 +open Stafford38.WeylFiltration +open Stafford38.Characteristic +open Stafford38.WeylPBW +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylSymplectic +open Stafford38.WeylLeadingSymbol +open Stafford + +noncomputable section +universe u + +/-! The (actual) Bernstein degree, read directly from checked PBW normal form. -/ +def bernsteinDegree (k : Type u) [Field k] {n : ℕ} + (d : PresentedWeyl k n) : ℕ := + MvPolynomial.weightedTotalDegree (@bernsteinWeight n) + (presentedNormalFormLinearEquiv k n d) + +def IsLinearWeylCoordinate (k : Type u) [Field k] (n : ℕ) + (ell : PresentedWeyl k (n + 1)) : Prop := + ∃ (M N : Matrix (PhaseVar (n + 1)) (PhaseVar (n + 1)) k) + (_hM : M * standardForm k (n + 1) * Matrix.transpose M = standardForm k (n + 1)) + (_hN : N * standardForm k (n + 1) * Matrix.transpose N = standardForm k (n + 1)) + (_hMN : M * N = 1) (_hNM : N * M = 1), + ell = freeWeylLinearCombination N + (freeWeylGenerator (standardForm k (n + 1))) + (.inl (0 : Fin (n + 1))) + +/-- The exact fixed-source strengthening: the source exponent is the actual +Bernstein degree of the input operator, and the source coordinate is obtained +from an invertible linear symplectic change of Weyl generators. -/ +def UniversalFixedSourceStatement : Prop := + ∀ (k : Type u) [Field k] [CharZero k] (n : ℕ) + (d : PresentedWeyl k (n + 1)), d ≠ 0 → + ∃ ell R S : PresentedWeyl k (n + 1), + IsLinearWeylCoordinate k n ell ∧ + (1 : PresentedWeyl k (n + 1)) = + d * R + ell ^ bernsteinDegree k d * d * S + +theorem bernsteinDegree_eq_of_piece_of_principal_ne_zero + (k : Type u) [Field k] {n N : ℕ} {d : PresentedWeyl k n} + (hp : d ∈ bernsteinPiece k n N) + (hP : presentedPrincipalComponent k (@bernsteinWeight n) N d ≠ 0) : + bernsteinDegree k d = N := by + let f := presentedNormalFormLinearEquiv k n d + have hle : bernsteinDegree k d ≤ N := by + apply Finset.sup_le + intro m hm + exact (hp m (MvPolynomial.mem_support_iff.mp hm)) + rcases MvPolynomial.support_nonempty.mpr hP with ⟨m, hm⟩ + have hm : MvPolynomial.coeff m + (presentedPrincipalComponent k (@bernsteinWeight n) N d) ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + have hcoeff := hm + rw [coeff_presentedPrincipalComponent] at hcoeff + have hweight : monomialWeight (@bernsteinWeight n) m = N := by + by_contra hne + have hz : MvPolynomial.coeff m + (presentedPrincipalComponent k (@bernsteinWeight n) N d) = 0 := by + rw [coeff_presentedPrincipalComponent] + simp [hne] + exact hm hz + have hfd : MvPolynomial.coeff m f ≠ 0 := by + rw [if_pos hweight] at hcoeff + simpa [f] using hcoeff + have hge : N ≤ bernsteinDegree k d := by + calc + N = monomialWeight (@bernsteinWeight n) m := hweight.symm + _ ≤ bernsteinDegree k d := + MvPolynomial.le_weightedTotalDegree _ (MvPolynomial.mem_support_iff.mpr hfd) + exact Nat.le_antisymm hle hge + +end +end Stafford38.FixedSource diff --git a/LeanPool/Stafford38/Stafford38/FoundationClosure.lean b/LeanPool/Stafford38/Stafford38/FoundationClosure.lean new file mode 100644 index 0000000000..7b0ee04c56 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/FoundationClosure.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalKoszulContradiction +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGabberInvolutivityInterface +import LeanPool.Stafford38.Stafford38.Geometry.ExactDivisorialVisibleFrameExistence +import LeanPool.Stafford38.Stafford38.PaperInputs +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter + +/-! The paper's three assembly interfaces and both universal statements are +proved from Lean and Mathlib without project or literature axioms. The final +canonical-support proof uses the general coisotropic-set theorem. + +## References and proof context + +[Sta78] J. T. Stafford, *Module Structure of Weyl Algebras*, Journal of the London Mathematical Society (2) 18 (1978), 429–442. +https://doi.org/10.1112/jlms/s2-18.3.429 + +Conjecture 3.8, p. 438, is the source problem. This project proves the general case and exact-degree strengthening. See docs/literature.md for the imported involutivity and visible-frame route. +-/ + +namespace Stafford38.FoundationClosure + +universe u + +theorem canonicalNoncharacteristicSupportAvoidance : + PaperInputs.CanonicalNoncharacteristicSupportAvoidance.{u} := by + intro k _ _ _ n N d hN hd + exact Characteristic.CanonicalKoszulContradiction.canonical_support_avoidance + k n N d hN hd + +def inputs : PaperInputs.Inputs.{u} where + noncharacteristicApplication := canonicalNoncharacteristicSupportAvoidance + residueExtensionSymbolControl := + Characteristic.CanonicalGabberInvolutivityInterface.canonicalResidueExtensionSymbolControl_of_associatedGradedRadical + Characteristic.GabberGlobalAssembly.weylAssociatedGradedRadicalInvolutivity + higherDimensionalVisibleDivisorFrameProduction := + Geometry.ExactDivisorialVisibleFrameExistence.higherDimensionalCanonicalVisibleDivisorFrameProduction + +theorem canonicalSupportVanishingViaGeneralCoisotropic : + UniversalAssembly.CanonicalSupportVanishing.{u} := by + let hunit : CanonicalSupportVanishingReduction.CanonicalStrictUnitCoordinatePreimage.{u} := by + intro k _ _ _ n N d hN hd + exact SpecializedNoncharacteristicEquality.strictUnitCoordinatePreimage_of_transposedSupport_disjoint_axis + k n N d (canonicalNoncharacteristicSupportAvoidance k n N d hN hd) + exact Weyl.FilteredScalarLifting.canonicalSupportDescent + (Geometry.GeneralCoisotropicCanonicalAdapter.algebraicallyClosedCanonicalSupportVanishing_of_generalCoisotropic + hunit) + +end Stafford38.FoundationClosure + +namespace Stafford38 + +universe u + +theorem universalStatement : UniversalStatement.{u} := + UniversalAssembly.universalStatement_of_canonicalSupportVanishing + FoundationClosure.canonicalSupportVanishingViaGeneralCoisotropic + +theorem universalFixedSourceStatement : FixedSource.UniversalFixedSourceStatement.{u} := + FixedSource.universalFixedSourceStatement_of_canonicalSupportVanishing + FoundationClosure.canonicalSupportVanishingViaGeneralCoisotropic + + +end Stafford38 diff --git a/LeanPool/Stafford38/Stafford38/Geometry/AffineComponentCoordinateSplit.lean b/LeanPool/Stafford38/Stafford38/Geometry/AffineComponentCoordinateSplit.lean new file mode 100644 index 0000000000..23d3082baf --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/AffineComponentCoordinateSplit.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.FieldTheory.IsAlgClosed.Basic +import Mathlib.RingTheory.Ideal.MinimalPrime.Basic +import Mathlib.RingTheory.Localization.FractionRing +import Mathlib.RingTheory.MvPolynomial.Basic +import Mathlib.RingTheory.Spectrum.Prime.Defs + +/-! +# Constant or transcendental coordinates on an affine component + +For a prime component over an algebraically closed field, a coordinate is +either constant on the component or transcendental in its function field. +Together with existence of a minimal prime over every proper affine ideal, +this gives the component split used before the divisorial-boundary +construction. +-/ + +namespace Stafford38.Geometry.AffineComponentCoordinateSplit + +open Polynomial + +noncomputable section + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The image of an affine coordinate in the fraction field of a prime +component. -/ +def componentCoordinate + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) : + FractionRing + (MvPolynomial (Fin m) k ⧸ P.asIdeal) := + algebraMap + (MvPolynomial (Fin m) k ⧸ P.asIdeal) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + (Ideal.Quotient.mk P.asIdeal (MvPolynomial.X i)) + +/-- On a prime affine component over an algebraically closed field, a +coordinate is either represented by a ground-field constant or is +transcendental in the component function field. -/ +theorem coordinate_constant_or_transcendental + [IsAlgClosed k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) : + (∃ c : k, MvPolynomial.X i - MvPolynomial.C c ∈ P.asIdeal) ∨ + Transcendental k (componentCoordinate P i) := by + classical + by_cases htr : Transcendental k (componentCoordinate P i) + · exact Or.inr htr + · left + have halg : IsAlgebraic k (componentCoordinate P i) := by + simpa only [Transcendental, not_not] using htr + have hint : IsIntegral k (componentCoordinate P i) := + isAlgebraic_iff_isIntegral.mp halg + let p := minpoly k (componentCoordinate P i) + have hpmonic : p.leadingCoeff = 1 := minpoly.monic hint + have hpdegree : p.degree = 1 := + IsAlgClosed.degree_eq_one_of_irreducible k (minpoly.irreducible hint) + have hroot : aeval (componentCoordinate P i) p = 0 := + minpoly.aeval k (componentCoordinate P i) + rw [eq_X_add_C_of_degree_eq_one hpdegree, hpmonic, Polynomial.C_1, + one_mul, aeval_add, aeval_X, aeval_C, add_eq_zero_iff_eq_neg] at hroot + let c : k := -p.coeff 0 + refine ⟨c, ?_⟩ + have hfield : + algebraMap k + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) c = + componentCoordinate P i := by + simpa only [c, map_neg] using hroot.symm + have hquotient : + algebraMap k (MvPolynomial (Fin m) k ⧸ P.asIdeal) c = + Ideal.Quotient.mk P.asIdeal (MvPolynomial.X i) := by + apply IsFractionRing.injective + (MvPolynomial (Fin m) k ⧸ P.asIdeal) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + change algebraMap k + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) c = + componentCoordinate P i + exact hfield + rw [← Ideal.Quotient.eq_zero_iff_mem] + rw [map_sub, ← MvPolynomial.algebraMap_eq, + Ideal.Quotient.mk_algebraMap] + exact sub_eq_zero.mpr hquotient.symm + +/-- Every proper affine ideal has a minimal-prime component on which the +distinguished coordinate is either constant or transcendental in the +component function field. Radicality is not needed for this component +selection theorem. -/ +theorem exists_minimalPrime_coordinate_constant_or_transcendental + [IsAlgClosed k] + (I : Ideal (MvPolynomial (Fin m) k)) (hproper : I ≠ ⊤) (i : Fin m) : + ∃ P : PrimeSpectrum (MvPolynomial (Fin m) k), + P.asIdeal ∈ I.minimalPrimes ∧ + I ≤ P.asIdeal ∧ + ((∃ c : k, MvPolynomial.X i - MvPolynomial.C c ∈ P.asIdeal) ∨ + Transcendental k (componentCoordinate P i)) := by + classical + let P₀ : I.minimalPrimes := Classical.choice (I.nonempty_minimalPrimes hproper) + let P : PrimeSpectrum (MvPolynomial (Fin m) k) := + ⟨P₀.1, P₀.2.isPrime⟩ + exact ⟨P, P₀.2, P₀.2.le, coordinate_constant_or_transcendental P i⟩ + + +end + +end Stafford38.Geometry.AffineComponentCoordinateSplit diff --git a/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalClosure.lean b/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalClosure.lean new file mode 100644 index 0000000000..619f13eb7d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalClosure.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Nullstellensatz +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan + +/-! +# Algebraic closure of the equation-defined affine conormal locus + +The equation-defined conormal locus over the contracted base zero set lies in +the reduced order support under the exact base-relative Gabber fragment. Since +that support is a polynomial zero locus, the algebraic closure hull of the +conormal locus lies there as well. + +This file uses the closure operator `V(I(S))` on field-valued affine points. +It does not identify a smooth scheme-theoretic conormal bundle or prove the +asymptotic conormal theorem at infinity. +-/ + +namespace Stafford38.Geometry.AffineConormalClosure + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- Phase points whose base coordinate lies in `V(I)` and whose fibre +coordinate belongs to the equation-defined embedded conormal at that point. -/ +def equationConormalLocus (I : Ideal (MvPolynomial (Fin n) k)) : + Set (PhaseVar n → k) := + {q | (∀ f ∈ I, + MvPolynomial.eval (fun i => q (Sum.inl i)) f = 0) ∧ + coordinateCovector (fun i => q (Sum.inr i)) ∈ + affineConormalSpace (fun i => q (Sum.inl i)) I} + +/-- Algebraic closure hull of the equation-defined conormal locus. -/ +def equationConormalClosure (I : Ideal (MvPolynomial (Fin n) k)) : + Set (PhaseVar n → k) := + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (equationConormalLocus I)) + +/-- A subset of a polynomial zero locus has its algebraic closure hull in the +same zero locus. -/ +theorem zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (S : Set (PhaseVar n → k)) (J : Ideal (SymbolRing k n)) + (h : S ⊆ MvPolynomial.zeroLocus k J) : + MvPolynomial.zeroLocus k (MvPolynomial.vanishingIdeal k S) ⊆ + MvPolynomial.zeroLocus k J := by + apply MvPolynomial.zeroLocus_anti_mono + exact MvPolynomial.le_zeroLocus_iff_le_vanishingIdeal.mp h + +/-- Under the exact base-relative Gabber condition, every equation-defined +conormal point over the contracted base zero locus lies in the reduced order +support. -/ +theorem equationConormalLocus_subset_reducedOrderSupport + [CharZero k] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k W)) : + equationConormalLocus (reducedOrderBaseIdeal k W) ⊆ + MvPolynomial.zeroLocus k (reducedOrderSupportIdeal k W) := by + intro q hq + let y : Fin n → k := fun i => q (Sum.inl i) + let ξ : Fin n → k := fun i => q (Sum.inr i) + have hs := reducedOrderBaseZero_affineConormal_coordinatePoint_isCommonZero + W hJ y hq.1 ξ hq.2 + have hsplit : Sum.elim y ξ = q := by + funext i + rcases i with i | i <;> rfl + rw [← hsplit] + exact hs + +/-- The algebraic closure hull of the equation-defined conormal locus remains +inside the reduced order support. -/ +theorem equationConormalClosure_subset_reducedOrderSupport + [CharZero k] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k W)) : + equationConormalClosure (reducedOrderBaseIdeal k W) ⊆ + MvPolynomial.zeroLocus k (reducedOrderSupportIdeal k W) := by + exact zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (equationConormalLocus (reducedOrderBaseIdeal k W)) + (reducedOrderSupportIdeal k W) + (equationConormalLocus_subset_reducedOrderSupport W hJ) + + +end + +end Stafford38.Geometry.AffineConormalClosure diff --git a/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalSpan.lean b/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalSpan.lean new file mode 100644 index 0000000000..d24a84fb9a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/AffineConormalSpan.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Dual.Lemmas +import Mathlib.LinearAlgebra.Finsupp.LinearCombination +import LeanPool.Stafford38.Stafford38.Characteristic.BaseZeroSection +import LeanPool.Stafford38.Stafford38.Geometry.PointwiseConormalContainment + +/-! +# Affine conormals are finite spans of equation differentials + +For an ideal of equations in affine space and a rational point, define the +embedded Zariski tangent space as the common kernel of the evaluated +differentials. Its annihilator is exactly the span of those differentials. +Because the ambient affine space is finite-dimensional, every conormal +covector is therefore an explicit finite linear combination of equation +differentials. + +The final theorem feeds that finite representation into the pointwise +Hamiltonian-translation theorem. No smoothness assumption is needed for this +linear-algebraic bridge. What is not proved here is the scheme-geometric +identification of this equation-defined tangent space with the tangent fibre +of a smooth locus, or the passage from pointwise fibres to the closure of the +smooth conormal bundle. +-/ + +namespace Stafford38.Geometry.AffineConormalSpan + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.BaseZeroSection +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Characteristic.ZeroSectionContainment +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.PointwiseConormalContainment +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +abbrev AffineTangentVector (k : Type*) (n : ℕ) := Fin n → k + +/-- The differential of `f` at `y`, viewed as a linear functional on the +ambient affine tangent space. -/ +def differentialCovector (y : Fin n → k) (f : MvPolynomial (Fin n) k) : + Module.Dual k (AffineTangentVector k n) where + toFun v := ∑ i, differentialAt y f i * v i + map_add' u v := by simp [mul_add, Finset.sum_add_distrib] + map_smul' a v := by simp [mul_assoc, mul_left_comm, mul_comm, Finset.mul_sum] + +@[simp] +theorem differentialCovector_apply (y : Fin n → k) + (f : MvPolynomial (Fin n) k) (v : AffineTangentVector k n) : + differentialCovector y f v = ∑ i, differentialAt y f i * v i := + rfl + +/-- Covectors generated by the differentials of all equations in `I`. -/ +def equationCovectorSpan (y : Fin n → k) + (I : Ideal (MvPolynomial (Fin n) k)) : + Submodule k (Module.Dual k (AffineTangentVector k n)) := + Submodule.span k (Set.range fun f : I ↦ differentialCovector y f.1) + +/-- The embedded Zariski tangent space cut out by the first-order parts of all +equations in `I`. -/ +def zariskiTangentSpace (y : Fin n → k) + (I : Ideal (MvPolynomial (Fin n) k)) : + Submodule k (AffineTangentVector k n) := + (equationCovectorSpan y I).dualCoannihilator + +/-- The embedded conormal space, defined as the annihilator of the embedded +Zariski tangent space. -/ +def affineConormalSpace (y : Fin n → k) + (I : Ideal (MvPolynomial (Fin n) k)) : + Submodule k (Module.Dual k (AffineTangentVector k n)) := + (zariskiTangentSpace y I).dualAnnihilator + +/-- The embedded conormal is exactly the span of evaluated differentials of +the equation ideal. This is finite-dimensional double-annihilator duality. -/ +theorem affineConormalSpace_eq_equationCovectorSpan + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) : + affineConormalSpace y I = equationCovectorSpan y I := by + classical + exact Subspace.dualCoannihilator_dualAnnihilator_eq + +/-- Every embedded conormal covector has an explicit finite-support expansion +in differentials of equations. -/ +theorem mem_affineConormalSpace_iff_exists_finsupp + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) + (phi : Module.Dual k (AffineTangentVector k n)) : + phi ∈ affineConormalSpace y I ↔ + ∃ c : I →₀ k, + Finsupp.linearCombination k (fun f : I ↦ differentialCovector y f.1) c = phi := by + classical + rw [affineConormalSpace_eq_equationCovectorSpan] + exact Finsupp.mem_span_range_iff_exists_finsupp + +/-- The coordinate covector associated with a fibre coordinate `xi`. -/ +def coordinateCovector (xi : Fin n → k) : + Module.Dual k (AffineTangentVector k n) where + toFun v := ∑ i, xi i * v i + map_add' u v := by simp [mul_add, Finset.sum_add_distrib] + map_smul' a v := by simp [mul_assoc, mul_left_comm, mul_comm, Finset.mul_sum] + +@[simp] +theorem coordinateCovector_apply (xi v : Fin n → k) : + coordinateCovector xi v = ∑ i, xi i * v i := + rfl + +/-- Equality of coordinate covectors recovers equality of their coordinates. -/ +theorem coordinateCovector_injective : + Function.Injective (coordinateCovector (k := k) (n := n)) := by + intro xi eta h + funext i + have hi := LinearMap.congr_fun h (Pi.single i 1) + simpa [coordinateCovector, Pi.single_apply] using hi + +/-- A conormal coordinate covector admits a finite-support expansion in +gradients of equations. -/ +theorem coordinate_mem_affineConormalSpace_exists_finsupp + (y xi : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) : + coordinateCovector xi ∈ affineConormalSpace y I → + ∃ c : I →₀ k, ∀ i, + xi i = ∑ f ∈ c.support, c f * differentialAt y f.1 i := by + classical + intro hxi + obtain ⟨c, hc⟩ := + (mem_affineConormalSpace_iff_exists_finsupp y I (coordinateCovector xi)).mp hxi + refine ⟨c, fun i ↦ ?_⟩ + have hi := LinearMap.congr_fun hc (Pi.single i 1) + simpa [Finsupp.linearCombination_apply, differentialCovector, coordinateCovector, + Pi.single_apply, Finsupp.sum, mul_comm, mul_left_comm, mul_assoc] using hi.symm + +/-- The genuine conormal consumer: under the existing base-relative Poisson +hypothesis, every coordinate covector in the equation-defined affine +conormal space gives a common zero in the corresponding support fibre. -/ +theorem affineConormal_coordinatePoint_isCommonZero + [CharZero k] + (J : Ideal (SymbolRing k n)) (hJ : IsBaseRelativePoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (I : Ideal (MvPolynomial (Fin n) k)) + (hlift : ∀ f : I, baseLift f.1 ∈ J) + (xi : Fin n → k) + (hxi : coordinateCovector xi ∈ affineConormalSpace y I) : + ∀ g ∈ J, MvPolynomial.eval (Sum.elim y xi) g = 0 := by + classical + obtain ⟨c, hc⟩ := + coordinate_mem_affineConormalSpace_exists_finsupp y xi I hxi + let ι := {f : I // f ∈ c.support} + let equations : ι → MvPolynomial (Fin n) k := fun f ↦ f.1.1 + let coefficients : ι → k := fun f ↦ c f.1 + have hpoint : differentialCombinationPoint y coefficients equations = Sum.elim y xi := by + funext q + rcases q with i | i + · rfl + · simp only [differentialCombinationPoint, coefficients, equations, Sum.elim_inr] + rw [hc i] + exact (Finset.sum_subtype c.support (by simp) + (fun f ↦ c f * differentialAt y f.1 i)).symm + rw [← hpoint] + exact differentialCombinationPoint_isCommonZero J hJ y hzero equations + (fun f ↦ hlift f.1) coefficients + +/-- Concrete characteristic-support form. If `(y, eta)` lies in the reduced +order support and the required base-relative Gabber fragment holds, then the +entire equation-defined conormal space of the contracted base ideal over `y` +lies in the same reduced support fibre. -/ +theorem reducedOrderSupport_affineConormal_coordinatePoint_isCommonZero + [CharZero k] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k W)) + (y eta : Fin n → k) + (hpoint : ∀ g ∈ reducedOrderSupportIdeal k W, + MvPolynomial.eval (Sum.elim y eta) g = 0) + (xi : Fin n → k) + (hxi : coordinateCovector xi ∈ + affineConormalSpace y (reducedOrderBaseIdeal k W)) : + ∀ g ∈ reducedOrderSupportIdeal k W, + MvPolynomial.eval (Sum.elim y xi) g = 0 := by + apply affineConormal_coordinatePoint_isCommonZero + (reducedOrderSupportIdeal k W) hJ y + (zeroSection_mem_of_mem_reducedOrderSupport_zeroSet k W y eta hpoint) + (reducedOrderBaseIdeal k W) + · intro f + exact (mem_reducedOrderBaseIdeal_iff k W f.1).mp f.2 + · exact hxi + +/-- Stronger contracted-base form: every equation-defined conormal covector +over a common zero of the contracted base ideal lies in the reduced support +fibre. No auxiliary point of that fibre is required. -/ +theorem reducedOrderBaseZero_affineConormal_coordinatePoint_isCommonZero + [CharZero k] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k W)) + (y : Fin n → k) + (hy : ∀ f ∈ reducedOrderBaseIdeal k W, + MvPolynomial.eval y f = 0) + (xi : Fin n → k) + (hxi : coordinateCovector xi ∈ + affineConormalSpace y (reducedOrderBaseIdeal k W)) : + ∀ g ∈ reducedOrderSupportIdeal k W, + MvPolynomial.eval (Sum.elim y xi) g = 0 := by + apply affineConormal_coordinatePoint_isCommonZero + (reducedOrderSupportIdeal k W) hJ y + (zeroSection_mem_of_mem_reducedOrderBaseZeroSet k W y hy) + (reducedOrderBaseIdeal k W) + · intro f + exact (mem_reducedOrderBaseIdeal_iff k W f.1).mp f.2 + · exact hxi + + +end + +end Stafford38.Geometry.AffineConormalSpan diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ArcFrameConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/ArcFrameConormal.lean new file mode 100644 index 0000000000..bdd36e9994 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ArcFrameConormal.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesArcTangency + +/-! +# From an annihilating arc frame to an affine conormal covector + +The power-series arc file proves that the uniformizer and coefficient-field +residue directions are tangent to the scalar-extended equation ideal. The +continuous-frame file separately proves that a finite independent family with +the correct tangent-dimension bound spans the tangent space. This file joins +those two facts and records the exact local tangent-to-conormal bridge. + +The result is deliberately affine and local. It does not construct a +divisorial chart, identify an arc with a projective component, or descend a +`K[[t]]` chart to `k[[t]]`. Those are still global production obligations for +`CanonicalAsymptoticLaurentProducer`. +-/ + +namespace Stafford38.Geometry.ArcFrameConormal + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +open Stafford38.Geometry.PowerSeriesArcTangency + +noncomputable section + +universe u v + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-! ## The frame-span bridge -/ + +/-- +An actual annihilating power-series arc makes the complete residue frame +tangent. If that finite frame is independent and its cardinality bounds the +tangent dimension, the equation-defined tangent space is contained in its +span. + +The coefficient directions are arbitrary `k`-derivations of the residue +field; no coefficient-field section of a geometric DVR is inferred here. +-/ +theorem tangent_le_span_residueFrame_of_annihilatingArc + {m : ℕ} {κ : Type v} [Fintype κ] + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : κ → Derivation k K K) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) + (hindependent : LinearIndependent K (residueFrameVector q D)) + (hfinrank : Module.finrank K + (zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K)))) ≤ + Fintype.card (FrameIndex κ)) : + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) ≤ + Submodule.span K (Set.range (residueFrameVector q D)) := by + apply tangent_le_span_residueFrame + (k := k) (K := K) + (I.map (MvPolynomial.map (algebraMap k K))) q D ?_ + hindependent hfinrank + intro j + cases j with + | none => + have hD := + residueDerivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + (k := k) (K := K) I q + (uniformizerDerivation (k := k) (K := K)) hq + change (fun i ↦ PowerSeries.constantCoeff + (uniformizerDerivation (k := k) (K := K) (q i))) ∈ _ + exact hD + | some j => + have hD := + residueDerivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + (k := k) (K := K) I q + (coefficientwiseDerivation (D j)) hq + change (fun i ↦ PowerSeries.constantCoeff + (coefficientwiseDerivation (D j) (q i))) ∈ _ + exact hD + +/-! ## The tangent-to-conormal bridge -/ + +/-- +If a covector annihilates every residue-frame direction of an annihilating +arc, then the frame-span bridge places that covector in the affine conormal +space of the scalar-extended equation ideal. + +The hypothesis is an explicit finite sum, so the theorem does not hide a +projective tangent comparison or a smoothness assertion. +-/ +theorem coordinateCovector_mem_affineConormalSpace_of_annihilatingArcFrame + {m : ℕ} {κ : Type v} [Fintype κ] + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : κ → Derivation k K K) + (xi : Fin m → K) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) + (hframe : ∀ j, + ∑ i, xi i * residueFrameVector q D j i = 0) + (hindependent : LinearIndependent K (residueFrameVector q D)) + (hfinrank : Module.finrank K + (zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K)))) ≤ + Fintype.card (FrameIndex κ)) : + coordinateCovector xi ∈ + affineConormalSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) := by + have htangent := tangent_le_span_residueFrame_of_annihilatingArc + (k := k) (K := K) I q D hq hindependent hfinrank + rw [affineConormalSpace, Submodule.mem_dualAnnihilator] + intro v hv + have hspan : ∀ w, + w ∈ Submodule.span K (Set.range (residueFrameVector q D)) → + coordinateCovector xi w = 0 := by + intro w hw + induction hw using Submodule.span_induction with + | mem w hw => + rcases hw with ⟨j, rfl⟩ + simpa [coordinateCovector_apply] using hframe j + | zero => + simp + | add w z hw hz ihw ihz => + rw [map_add, ihw, ihz, add_zero] + | smul a w hw ih => + rw [map_smul, ih, smul_zero] + exact hspan v (htangent hv) + + +end + +end Stafford38.Geometry.ArcFrameConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticChartArcAdapter.lean b/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticChartArcAdapter.lean new file mode 100644 index 0000000000..4397040a89 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticChartArcAdapter.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveBoundaryFrameRank +import LeanPool.Stafford38.Stafford38.Geometry.ArcFrameConormal +import LeanPool.Stafford38.Stafford38.Geometry.JacobianConormalComparison + +/-! +# The exact completed-chart to arc-frame adapter boundary + +The completed projective certificate canonically supplies an affine +power-series arc after deleting its normalized chart coordinate. Its +dehomogenized first jet is exactly the uniformizer member of +`residueFrameVector`. + +The remaining projective residue columns cannot be interpreted as +coefficient-field derivations over the field stored in the certificate: every +`k`-derivation of `k` is zero, whereas those columns are independent. Thus a +smaller base field and geometric residue-field derivations are genuinely new +data, not consequences of `CompletedProjectiveBoundaryChart`. + +For the separate closed-tangent obligation, independent Jacobian rows from +the actual boundary ideal give the sharp annihilator-dimension formula and +therefore the finrank bound consumed by `ArcFrameConormal`. This regularity +criterion concerns the closed point directly; no generic-rank specialization +is used. +-/ + +namespace Stafford38.Geometry.AsymptoticChartArcAdapter + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.ArcFrameConormal +open Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +open Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +open Stafford38.Geometry.JacobianConormalComparison +open Stafford38.Geometry.ProjectiveBoundaryFrameRank +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u v + +variable {k : Type u} [Field k] + +/-! ## The canonical affine arc and its first jet -/ + +/-- The complement of one coordinate in `Fin (m+1)` has `m` elements. -/ +def chartAffineCoordinateEquiv {m : ℕ} (chart : Fin (m + 1)) : + Fin m ≃ ChartAffineIndex (Fin (m + 1)) chart := by + classical + apply (Fintype.equivFinOfCardEq (α := ChartAffineIndex (Fin (m + 1)) chart) ?_).symm + rw [Fintype.card_subtype_compl] + simp + +/-- Affine power-series coordinates obtained by deleting the normalized +projective chart coordinate. Since that coordinate is exactly one, no +power-series division is needed. -/ +def completedChartAffineArc [CharZero k] + {m : ℕ} (hm : 0 < m) (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) : + Fin m → PowerSeries k := + fun i ↦ W.q ((chartAffineCoordinateEquiv W.chart i).1) + +/-- The first coefficient of every projective power-series coordinate. -/ +def projectiveFirstJet {ι : Type v} (q : ι → PowerSeries k) : ι → k := + fun i ↦ PowerSeries.coeff 1 (q i) + +/-- The actual uniformizer residue vector of the affine chart arc is exactly +the dehomogenized projective first jet. -/ +theorem completedChart_uniformizerResidueFrame_eq_dehomogenizedFirstJet + [CharZero k] {m r : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) + (D : Fin r → Derivation k k k) (i : Fin m) : + residueFrameVector (completedChartAffineArc hm I W) D none i = + chartDehomogenizedTangentColumn W.chart + (residueColumn W.q) (projectiveFirstJet W.q) + (chartAffineCoordinateEquiv W.chart i) := by + simp [completedChartAffineArc, chartDehomogenizedTangentColumn, + projectiveFirstJet, residueColumn, W.q_chart] + +/-! ## Why the remaining columns are not a self-relative arc frame -/ + +/-- Every derivation of a field relative to itself is zero. -/ +theorem selfDerivation_apply_eq_zero (D : Derivation k k k) (a : k) : + D a = 0 := by + simpa using D.map_algebraMap a + +/-- Consequently every coefficient member of a `k/k` residue frame is the +zero tangent vector. -/ +theorem residueFrameVector_coefficient_self_eq_zero + {m : ℕ} (q : Fin m → PowerSeries k) + {κ : Type v} (D : κ → Derivation k k k) (j : κ) : + residueFrameVector q D (some j) = 0 := by + funext i + rw [residueFrameVector_coefficient] + exact selfDerivation_apply_eq_zero (D j) _ + +/-- If the completed chart has at least one divisor-tangent column, its +independent projective residue frame cannot equal a coefficient-derivation +frame over `k/k`, even after the canonical affine-coordinate reindexing. -/ +theorem completedChart_no_selfRelative_fullResidueFrameIdentification + [CharZero k] {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) + (hpositive : 0 < W.tangentCount) : + ¬ ∃ (q : Fin m → PowerSeries k) + (D : Fin W.tangentCount → Derivation k k k), + ∀ (j : Fin W.tangentCount) (i : Fin m), + residueFrameVector q D (some j) i = + chartDehomogenizedTangentColumn W.chart + (residueColumn W.q) + (fun a ↦ PowerSeries.constantCoeff + (nonpositionPowerSeriesMatrix W.Z W.tau a (Sum.inl j))) + (chartAffineCoordinateEquiv W.chart i) := by + rintro ⟨q, D, hidentify⟩ + let j : Fin W.tangentCount := ⟨0, hpositive⟩ + have hprojective := + (completedBoundaryChart_residueFrame_linearIndependent hm I W).ne_zero + (Sum.inl j) + apply hprojective + funext a + let i : Fin m := (chartAffineCoordinateEquiv W.chart).symm a + have hz := congrFun (residueFrameVector_coefficient_self_eq_zero q D j) i + have hid := hidentify j i + have hres : residueColumn W.q = fun i ↦ PowerSeries.constantCoeff (W.q i) := rfl + simpa [i, hres, Equiv.apply_symm_apply] using hid.symm.trans hz + +/-! ## Closed-boundary Jacobian regularity -/ + +/-- Independent Jacobian rows have the expected common-kernel dimension. -/ +theorem finrank_jacobianTangentSpace_eq_sub_of_linearIndependent + {n : ℕ} {ι : Type v} [Fintype ι] + (y : Fin n → k) (equations : ι → MvPolynomial (Fin n) k) + (hindependent : + LinearIndependent k (fun i ↦ differentialCovector y (equations i))) : + Module.finrank k (jacobianTangentSpace y equations) = + n - Fintype.card ι := by + have hspan : Module.finrank k (jacobianCovectorSpan y equations) = + Fintype.card ι := by + exact finrank_span_eq_card hindependent + have hdimension := + Subspace.finrank_add_finrank_dualCoannihilator_eq + (jacobianCovectorSpan y equations) + rw [hspan, Module.finrank_pi, Fintype.card_fin] at hdimension + rw [jacobianTangentSpace] + omega + +/-- Independent differentials of equations belonging to `I` give a sharp +upper bound on the equation-defined closed tangent space. -/ +theorem zariskiTangent_finrank_le_sub_of_independentEquations + {n : ℕ} {ι : Type v} [Fintype ι] + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) + (hindependent : + LinearIndependent k (fun i ↦ differentialCovector y (equations i))) : + Module.finrank k (zariskiTangentSpace y I) ≤ + n - Fintype.card ι := by + have hcovectors : + jacobianCovectorSpan y equations ≤ equationCovectorSpan y I := + jacobianCovectorSpan_le_equationCovectorSpan y I equations hequations + have htangent : zariskiTangentSpace y I ≤ + jacobianTangentSpace y equations := by + exact Submodule.dualCoannihilator_anti hcovectors + calc + Module.finrank k (zariskiTangentSpace y I) ≤ + Module.finrank k (jacobianTangentSpace y equations) := + Submodule.finrank_mono htangent + _ = n - Fintype.card ι := + finrank_jacobianTangentSpace_eq_sub_of_linearIndependent + y equations hindependent + +/-- Cardinal form matching the `ArcFrameConormal` consumer: enough +independent closed-point Jacobian equations discharge its finrank input. -/ +theorem zariskiTangent_finrank_le_frameCard_of_independentEquations + {n frameCount : ℕ} {ι : Type v} [Fintype ι] + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) + (hindependent : + LinearIndependent k (fun i ↦ differentialCovector y (equations i))) + (hcodimension : n ≤ Fintype.card ι + frameCount) : + Module.finrank k (zariskiTangentSpace y I) ≤ frameCount := by + have hbound := zariskiTangent_finrank_le_sub_of_independentEquations + y I equations hequations hindependent + omega + +/-- An annihilating arc with an independent residue frame spans the closed +tangent space once enough independent boundary Jacobian equations are +exhibited. The finrank premise of `ArcFrameConormal` is now a conclusion. -/ +theorem tangent_le_span_residueFrame_of_independentBoundaryEquations + {K : Type u} [Field K] [Algebra k K] + {m : ℕ} {κ : Type v} [Fintype κ] + {ι : Type v} [Fintype ι] + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : κ → Derivation k K K) + (equations : ι → MvPolynomial (Fin m) K) + (hequations : ∀ i, + equations i ∈ I.map (MvPolynomial.map (algebraMap k K))) + (hjacobian : LinearIndependent K (fun i ↦ + differentialCovector + (fun a ↦ PowerSeries.constantCoeff (q a)) (equations i))) + (hcodimension : + m ≤ Fintype.card ι + Fintype.card (FrameIndex κ)) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) + (hframe : LinearIndependent K (residueFrameVector q D)) : + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) ≤ + Submodule.span K (Set.range (residueFrameVector q D)) := by + apply tangent_le_span_residueFrame_of_annihilatingArc I q D hq hframe + exact zariskiTangent_finrank_le_frameCard_of_independentEquations + _ _ equations hequations hjacobian hcodimension + + +end + +end Stafford38.Geometry.AsymptoticChartArcAdapter diff --git a/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticDivisorExistence.lean b/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticDivisorExistence.lean new file mode 100644 index 0000000000..c0c2c34a06 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/AsymptoticDivisorExistence.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import Mathlib.FieldTheory.IsAlgClosed.Basic +import Mathlib.Algebra.Polynomial.FieldDivision +import Mathlib.RingTheory.DedekindDomain.Dvr +import Mathlib.RingTheory.Localization.AtPrime.Basic +import Mathlib.RingTheory.PrincipalIdealDomain +import Mathlib.RingTheory.Valuation.LocalSubring + +/-! +# A scheme-free boundary valuation for a nonconstant affine coordinate + +The global asymptotic-conormal argument needs a boundary place at which the +distinguished affine coordinate tends to zero. This file constructs that +place without projective schemes or normalization. + +If `x` is transcendental over `k` in a field `K`, evaluation embeds the DVR +`k[X]_(X)` in `K`; its parameter maps to `x`. This already produces the +strict order gap for the rational projective pair `[x:x²]`. Independently, +Zorn's theorem extends the local map to a valuation subring of all of `K`, +which contains `x` in its maximal ideal and excludes `x⁻¹`. + +The exact remaining commutative-algebra input is a *discrete extension* of +this place to the finitely generated function field: a discrete valuation +subring of `K` centred at `x=0`. Mathlib has the unrestricted valuation-ring +extension and the source DVR, but no theorem preserving rank one/discreteness +under the extension (nor the equivalent normalization/height-one-prime +construction). +-/ + +namespace Stafford38.Geometry.AsymptoticDivisorExistence + +open IsLocalRing +open Polynomial + +noncomputable section + +universe u v + +variable (k : Type u) [Field k] + +/-- Over an algebraically closed ground field, "nonconstant" is exactly the +input needed below: an element outside the scalar image is transcendental. -/ +theorem transcendental_of_not_mem_range_algebraMap + {K : Type v} [Field K] [Algebra k K] [IsAlgClosed k] + {x : K} (hx : x ∉ Set.range (algebraMap k K)) : + Transcendental k x := by + change ¬IsAlgebraic k x + intro halg + let L : IntermediateField k K := IntermediateField.adjoin k {x} + letI : Algebra.IsAlgebraic k L := + IntermediateField.isAlgebraic_adjoin (K := k) (L := K) (S := {x}) (by + intro y hy + simpa only [Set.mem_singleton_iff] using hy ▸ halg.isIntegral) + have hL : L = ⊥ := + IntermediateField.eq_bot_of_isAlgClosed_of_isAlgebraic L + apply hx + rw [← IntermediateField.mem_bot, ← hL] + exact IntermediateField.subset_adjoin k {x} (Set.mem_singleton x) + +/-- The prime ideal `(X)` in the one-variable polynomial ring. -/ +def coordinateZeroPrime : Ideal (Polynomial k) := Ideal.span {Polynomial.X} + +instance coordinateZeroPrime_isPrime : (coordinateZeroPrime k).IsPrime := by + exact (Ideal.span_singleton_prime Polynomial.X_ne_zero).2 Polynomial.prime_X + +/-- The local ring of the affine line at the origin. -/ +abbrev CoordinateZeroLocalRing := Localization.AtPrime (coordinateZeroPrime k) + +instance coordinateZeroLocalRing_isDiscreteValuationRing : + IsDiscreteValuationRing (CoordinateZeroLocalRing k) := by + apply IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (Polynomial k) (P := coordinateZeroPrime k) + · rw [coordinateZeroPrime, ne_eq, Ideal.span_singleton_eq_bot] + exact Polynomial.X_ne_zero + +/-- Evaluation at a transcendental element extends from `k[X]` to the local +ring at `(X)`, because every polynomial outside `(X)` is nonzero and hence a +unit in the ambient field. -/ +def coordinateZeroLocalMap + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + CoordinateZeroLocalRing k →+* K := + IsLocalization.lift (S := CoordinateZeroLocalRing k) + (M := (coordinateZeroPrime k).primeCompl) + (g := (Polynomial.aeval x).toRingHom) fun y ↦ by + rw [isUnit_iff_ne_zero] + intro hy + have hy0 : (y : Polynomial k) = 0 := by + apply transcendental_iff_injective.mp hx + simpa using hy + exact y.2 (hy0 ▸ (coordinateZeroPrime k).zero_mem) + +@[simp] +theorem coordinateZeroLocalMap_algebraMap_X + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + coordinateZeroLocalMap k x hx + (algebraMap k[X] (CoordinateZeroLocalRing k) Polynomial.X) = x := by + rw [coordinateZeroLocalMap, IsLocalization.lift_eq] + exact Polynomial.aeval_X x + +/-- The coordinate-zero DVR map is an embedding, not merely a place with a +kernel. Thus the remaining problem is extension of this discrete valuation, +not repair of the source local model. -/ +theorem coordinateZeroLocalMap_injective + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + Function.Injective (coordinateZeroLocalMap k x hx) := by + rw [coordinateZeroLocalMap, IsLocalization.lift_injective_iff] + intro a b + have hloc := IsLocalization.injective (CoordinateZeroLocalRing k) + (coordinateZeroPrime k).primeCompl_le_nonZeroDivisors + have heval := transcendental_iff_injective.mp hx + constructor + · intro hab + exact congrArg (Polynomial.aeval x) (hloc hab) + · intro hab + exact congrArg (algebraMap (Polynomial k) (CoordinateZeroLocalRing k)) + (heval hab) + +/-- The local line at `x = 0` is already a DVR and maps to the ambient +function field. Consequently the rational projective pair `[x:x²]` has the +strict order gap required by `ProjectiveDivisorOrderGap`, unconditionally. + +This is a genuine rank-one discrete producer, stronger than the Zorn +valuation below. It does not yet contain the remaining affine coordinates; +extending this DVR place to the whole finitely generated function field while +retaining discreteness is the named residual theorem. -/ +theorem exists_coordinateZeroDVR_projectiveOrderGap + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + let R := CoordinateZeroLocalRing k + let q : R := algebraMap (Polynomial k) R Polynomial.X + ∃ (uniformizer : R) (a r b : ℕ) (u₀ ur u₁ : Rˣ), + coordinateZeroLocalMap k x hx q = x ∧ + Irreducible uniformizer ∧ + 0 < a ∧ 0 < r ∧ b = a + r ∧ a < b ∧ + q = (u₀ : R) * uniformizer ^ a ∧ + q = (ur : R) * uniformizer ^ r ∧ + u₁ = u₀ * ur ∧ + q * q = (u₁ : R) * uniformizer ^ b := by + let R := CoordinateZeroLocalRing k + let q : R := algebraMap (Polynomial k) R Polynomial.X + have hq_ne : q ≠ 0 := by + intro hq + apply Polynomial.X_ne_zero (R := k) + apply IsLocalization.injective R + (coordinateZeroPrime k).primeCompl_le_nonZeroDivisors + simpa only [q, map_zero] using hq + have hq_vanish : q ∈ maximalIdeal R := by + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff + R (coordinateZeroPrime k) Polynomial.X).2 + (Ideal.mem_span_singleton_self Polynomial.X) + obtain ⟨uniformizer, huniformizer⟩ := + IsDiscreteValuationRing.exists_irreducible R + obtain ⟨a, r, b, u₀, ur, u₁, ha, hr, hb, hab, + hq₀, hratio, hu₁, hq₁⟩ := + ProjectiveDivisorOrderGap.exists_uniformizer_strict_orderGap + uniformizer huniformizer q q (q * q) + hq_ne hq_ne hq_vanish hq_vanish rfl + exact ⟨uniformizer, a, r, b, u₀, ur, u₁, + coordinateZeroLocalMap_algebraMap_X k x hx, huniformizer, + ha, hr, hb, hab, hq₀, hratio, hu₁, hq₁⟩ + +/-- The complete scheme-free boundary-place package: a valuation subring of +the ambient function field together with a *local* factorization of +`k[X]_(X) → K`. Locality records that the centre really lies over `(X)`; +`factor_commutes` records that no abstract replacement of the coordinate map +has been made. -/ +structure BoundaryValuationData + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) where + valuation : ValuationSubring K + factor : CoordinateZeroLocalRing k →+* valuation.toSubring + factor_isLocal : IsLocalHom factor + factor_commutes : + valuation.toSubring.subtype.comp factor = coordinateZeroLocalMap k x hx + +/-- The exact divisorial refinement missing from the library. Unlike +`BoundaryValuationData`, this package asks that the valuation ring be a DVR. +It is deliberately only a data structure: this file does not postulate that +such a refinement exists. + +The classical missing theorem is: + +*Divisorial valuation extension.* If `K/k` is a finitely generated function +field and `x ∈ K` is nonconstant, then there is a discrete valuation subring +of `K` in whose maximal ideal `x` lies. + +For the Stafford application `x` is also a unit of the affine coordinate +domain, so this centre is necessarily on the boundary. -/ +structure DiscreteBoundaryRefinement + {K : Type v} [Field K] [Algebra k K] + (x : K) where + valuation : ValuationSubring K + isDiscrete : IsDiscreteValuationRing valuation.toSubring + coordinate : valuation.toSubring + coordinate_eq : (coordinate : K) = x + coordinate_ne : coordinate ≠ 0 + coordinate_nonunit : ¬IsUnit coordinate + +/-- Zorn's valuation-ring theorem produces the complete local factorization +of the coordinate-zero local ring inside the function field. -/ +theorem exists_boundaryValuationData + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + Nonempty (BoundaryValuationData k x hx) := by + let f := coordinateZeroLocalMap k x hx + obtain ⟨V, hV, hlocal⟩ := IsLocalRing.exists_factor_valuationRing f + exact ⟨{ + valuation := V + factor := f.codRestrict V.toSubring hV + factor_isLocal := hlocal + factor_commutes := rfl + }⟩ + +/-- A genuine discrete boundary refinement feeds the already formalized DVR +order-gap theorem with no further geometry hidden in the implication. + +The rational projective pair is `[q₀:q₁]=[x:x²]`; its affine ratio is `x`. +At the discrete boundary both `q₀` and the ratio vanish, so their orders are + strictly separated. This is the exact handoff from a full-function-field +discrete refinement; existence of that refinement is the missing theorem. -/ +theorem exists_projectiveOrderGap_of_discreteBoundaryRefinement + {K : Type v} [Field K] [Algebra k K] + (x : K) (D : DiscreteBoundaryRefinement k x) : + let R := D.valuation.toSubring + ∃ (uniformizer : R) (a r b : ℕ) (u₀ ur u₁ : Rˣ), + Irreducible uniformizer ∧ + 0 < a ∧ 0 < r ∧ b = a + r ∧ a < b ∧ + D.coordinate = (u₀ : R) * uniformizer ^ a ∧ + D.coordinate = (ur : R) * uniformizer ^ r ∧ + u₁ = u₀ * ur ∧ + D.coordinate * D.coordinate = (u₁ : R) * uniformizer ^ b := by + let R := D.valuation.toSubring + letI : IsDiscreteValuationRing R := D.isDiscrete + obtain ⟨uniformizer, huniformizer⟩ := + IsDiscreteValuationRing.exists_irreducible R + have hvanish : D.coordinate ∈ maximalIdeal R := by + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact D.coordinate_nonunit + obtain ⟨a, r, b, u₀, ur, u₁, ha, hr, hb, hab, + hq₀, hratio, hu₁, hq₁⟩ := + ProjectiveDivisorOrderGap.exists_uniformizer_strict_orderGap + uniformizer huniformizer + D.coordinate D.coordinate (D.coordinate * D.coordinate) + D.coordinate_ne D.coordinate_ne hvanish hvanish rfl + exact ⟨uniformizer, a, r, b, u₀, ur, u₁, huniformizer, + ha, hr, hb, hab, hq₀, hratio, hu₁, hq₁⟩ + +/-- A nonconstant coordinate has a scheme-free boundary valuation. + +The valuation subring is obtained by dominating `k[X]_(X)` inside `K`. +The first conclusion says that the chosen coordinate lies at the centre; +the second says its inverse has a pole there. -/ +theorem exists_boundaryValuationSubring + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + ∃ V : ValuationSubring K, + ∃ xV : V.toSubring, + (xV : K) = x ∧ + x⁻¹ ∉ V ∧ + ¬IsUnit xV := by + let R := CoordinateZeroLocalRing k + let f : R →+* K := coordinateZeroLocalMap k x hx + obtain ⟨D⟩ := exists_boundaryValuationData k x hx + let V := D.valuation + let fV : R →+* V.toSubring := D.factor + letI hlocalV : IsLocalHom fV := D.factor_isLocal + let xR : R := algebraMap k[X] R Polynomial.X + have hxR : xR ∈ maximalIdeal R := by + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff + R (coordinateZeroPrime k) Polynomial.X).2 + (Ideal.mem_span_singleton_self Polynomial.X) + have hfx : f xR = x := by + exact coordinateZeroLocalMap_algebraMap_X k x hx + let xV : V.toSubring := fV xR + have hxV : (xV : K) = x := by + have hcomm := D.factor_commutes + have := DFunLike.congr_fun hcomm xR + exact this.trans hfx + have hxR_nonunit : ¬IsUnit xR := mem_nonunits_iff.mp hxR + have hxnonunit : ¬IsUnit xV := by + intro hu + apply hxR_nonunit + exact @IsLocalHom.map_nonunit _ _ _ _ _ _ fV hlocalV xR hu + have hxinv : x⁻¹ ∉ V := by + intro hxinvV + have hxunit : IsUnit xV := by + apply isUnit_iff_exists_inv.mpr + refine ⟨⟨x⁻¹, hxinvV⟩, ?_⟩ + apply Subtype.ext + change (xV : K) * x⁻¹ = (1 : K) + rw [hxV] + exact mul_inv_cancel₀ (by + intro hx0 + apply hx + simpa [hx0] using (isAlgebraic_zero : IsAlgebraic k (0 : K))) + exact hxnonunit hxunit + exact ⟨V, xV, hxV, hxinv, hxnonunit⟩ + +/-- Algebraically closed form: a nonconstant coordinate directly produces +the boundary valuation, with no separately supplied transcendence proof. -/ +theorem exists_boundaryValuationSubring_of_nonconstant + {K : Type v} [Field K] [Algebra k K] [IsAlgClosed k] + (x : K) (hx : x ∉ Set.range (algebraMap k K)) : + ∃ V : ValuationSubring K, + ∃ xV : V.toSubring, + (xV : K) = x ∧ + x⁻¹ ∉ V ∧ + ¬IsUnit xV := + exists_boundaryValuationSubring k x + (transcendental_of_not_mem_range_algebraMap k hx) + +/-- Coordinate-ring form of the construction. If an affine coordinate is +a unit (the algebraic meaning of avoiding its zero hyperplane) and remains +nonconstant in a function field, then there is a boundary valuation which +contains the coordinate but excludes the image of its *regular inverse*. + +For a prime affine ideal one applies this to its quotient domain and its +fraction field; the unit is supplied by `I + (x) = ⊤`. -/ +theorem exists_boundaryValuationSubring_of_affineUnit + [IsAlgClosed k] + {A : Type*} [CommRing A] [IsDomain A] [Algebra k A] + {K : Type v} [Field K] [Algebra k K] + (ι : A →ₐ[k] K) (u : Aˣ) + (hu : ι (u : A) ∉ Set.range (algebraMap k K)) : + ∃ V : ValuationSubring K, + ∃ xV : V.toSubring, + (xV : K) = ι (u : A) ∧ + ι (u⁻¹ : Aˣ) ∉ V ∧ + ¬IsUnit xV := by + obtain ⟨V, xV, hxV, hxinv, hxnonunit⟩ := + exists_boundaryValuationSubring_of_nonconstant k (ι (u : A)) hu + refine ⟨V, xV, hxV, ?_, hxnonunit⟩ + have hprod : ι (u : A) * ι (u⁻¹ : Aˣ) = 1 := by + rw [← map_mul] + simp + have hinv : ι (u⁻¹ : Aˣ) = (ι (u : A))⁻¹ := + eq_inv_of_mul_eq_one_right hprod + rw [hinv] + exact hxinv + + +end + +end Stafford38.Geometry.AsymptoticDivisorExistence diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalAsymptoticLaurentProducer.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalAsymptoticLaurentProducer.lean new file mode 100644 index 0000000000..dbc9700274 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalAsymptoticLaurentProducer.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveEquationFormalChart +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveTangentInclusion + +/-! +# The completed-boundary consumer for the Laurent producer + +This file isolates the exact local certificate consumed by the asymptotic +Laurent step. A certificate contains + +* a one-parameter completed projective chart `q`; +* a finite homogeneous family of projective equations, with their vanishing + at `q` and containment of the target affine ideal after dehomogenization; +* divisor-tangent columns `Z` and the strict projective order-gap data; +* one fixed derivative-compatible geometric witness `tau`, `C`, `ell`; and +* the one genuinely geometric comparison still needed by the consumer: + the Zariski tangent space is *contained* in the span built from that same + fixed transverse column `tau`. + +The main theorem below turns this certificate into the exact output required +by `CanonicalAsymptoticLaurentProducer`. It does not assume support +vanishing, a finite affine point on the axis, tangent-space equality, or a +heuristic derivative limit. The certificate is therefore a non-circular +consumer interface, not a disguised proof of its own existence. + +What is deliberately not asserted here is the global production theorem that +constructs such a certificate from normalization and projective closure. In +particular, a DVR with residue field `K` naturally completes to `K[[X]]`; +specializing that chart to `k[[X]]`, constructing homogeneous equations, and +proving the tangent-span inclusion are separate geometric obligations. +`CanonicalBoundaryChartProduction` records exactly that remaining obligation. +-/ + +namespace Stafford38.Geometry.CanonicalAsymptoticLaurentProducer + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ProjectiveDivisorOrderGap +open Stafford38.Geometry.ProjectiveEquationFormalChart +open Stafford38.Geometry.ProjectiveTangentInclusion +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometrySplitTangentMatrix +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryPowerSeriesTangentLimit +open Stafford38.GeometryRetractionSpecialization +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +/-! ## The exact local certificate -/ + +/-- +A completed one-parameter projective boundary chart for an affine ideal in +`m` variables. + +The finite equation and tangent-column indices are natural numbers so that +the certificate is entirely first-order data over the pinned Lean library; +no hidden finiteness or choice of an equation family is left to an +elaboration-side typeclass. + +The formal tangent data are one fixed geometric witness. In particular, +`tangent_inclusion` refers to the stored derivative-compatible transverse +column `tau`; it does not quantify over alternative, possibly nongeometric, +split columns. The inclusion remains intentionally one-sided: it asks for +the actual Zariski tangent space to lie in the supplied span and never assumes +equality. +-/ +structure CompletedProjectiveBoundaryChart + (k : Type u) [Field k] [CharZero k] + (m : ℕ) (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) where + equationCount : ℕ + tangentCount : ℕ + equations : Fin equationCount → + MvPolynomial (Fin (m + 1)) (LaurentSeries k) + degree : Fin equationCount → ℕ + homogeneous : ∀ j, (equations j).IsHomogeneous (degree j) + q : Fin (m + 1) → PowerSeries k + Z : Matrix (Fin (m + 1)) (Fin tangentCount) (PowerSeries k) + rows : Fin tangentCount ↪ Fin (m + 1) + chart : Fin (m + 1) + zero : Fin (m + 1) + axis : Fin (m + 1) + ratio : PowerSeries k + q_chart : q chart = 1 + Z_chart : ∀ j, Z chart j = 0 + q_zero_ne : q zero ≠ 0 + q_origin_ne : q 0 ≠ 0 + ratio_ne : ratio ≠ 0 + q_zero_vanish : PowerSeries.constantCoeff (q zero) = 0 + ratio_vanish : PowerSeries.constantCoeff ratio = 0 + q_axis : q axis = q zero * ratio + Z_zero_dvd : ∀ j, q zero ∣ Z zero j + Z_axis_dvd : ∀ j, q axis ∣ Z axis j + selected_minor_nonzero : + PowerSeries.constantCoeff + (selectedMinor Z rows).det ≠ 0 + equations_vanish : + ∀ j, MvPolynomial.eval (laurentColumn q) (equations j) = 0 + ideal_containment : + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) ≤ + dehomogenizedEquationIdeal equations + axis_is_first_fibre : axis = Fin.succ ⟨0, hm⟩ + tau : Fin (m + 1) → PowerSeries k + C : Matrix (FormalTangentColumn (Fin tangentCount)) + (Fin (m + 1)) (PowerSeries k) + ell : Fin (m + 1) → PowerSeries k + left_inverse : C * formalTangentMatrix q Z tau = 1 + annihilation : rowMul ell (formalTangentMatrix q Z tau) = 0 + residue_axis : residueColumn ell = axisRow (k := k) axis + tangent_inclusion : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m))) ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) + +/-! ## Local consumer theorem -/ + +/-- +The completed-DVR/projective certificate supplies the Laurent conormal axis. + +The proof has four explicit interfaces: the projective order-gap theorem +constructs the formal annihilating row; homogeneous equation vanishing gives +the base-equation condition after dehomogenization; tangent inclusion feeds +the weaker Laurent conormal bridge; and the axis equation identifies the +regular fibre residue with the pure first momentum direction. +-/ +theorem exists_conormalAxis_of_completedProjectiveBoundaryChart + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) : + ∃ (y : Fin m → LaurentSeries k) + (xi : Fin m → PowerSeries k), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m))) ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + classical + let Iext := I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) + have hbase : ∀ f ∈ Iext, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn W.q)) f = 0 := by + intro f hf + exact eval_eq_zero_of_mem_dehomogenizedEquationIdeal + W.equations W.degree W.homogeneous (laurentColumn W.q) + (laurentColumn_ne_zero_of_ne_zero W.q W.q_origin_ne) + W.equations_vanish f (W.ideal_containment hf) + have htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn W.q)) Iext ≤ + dehomogenizedTangentSpan (laurentColumn W.q) + (laurentNonpositionTangentMatrix W.Z W.tau) := by + exact W.tangent_inclusion + have hphase := + laurentPhasePoint_mem_equationConormalLocus_of_zariski_le_span + Iext W.q W.ell W.Z W.tau W.q_origin_ne W.annihilation hbase htangent + refine ⟨dehomogenizedPoint (laurentColumn W.q), + (fun i : Fin m ↦ W.ell i.succ), ?_, ?_⟩ + · simpa [Iext, laurentColumn] using hphase + · calc + residueColumn (fun i : Fin m ↦ W.ell i.succ) = + (fun i : Fin m ↦ residueColumn W.ell i.succ) := + residueColumn_tail W.ell + _ = (fun i : Fin m ↦ axisRow (k := k) W.axis i.succ) := by + rw [W.residue_axis] + _ = (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + funext i + rw [W.axis_is_first_fibre] + by_cases hi : i = ⟨0, hm⟩ + · subst i + simp [axisRow] + · have hne : i.succ ≠ Fin.succ ⟨0, hm⟩ := by + intro h + exact hi (Fin.succ_injective m h) + change (if i.succ = Fin.succ ⟨0, hm⟩ then 1 else 0) = + (if i = ⟨0, hm⟩ then 1 else 0) + rw [if_neg hne, if_neg hi] + +/-! ## The remaining global production obligation -/ + +/-- +The exact global theorem still needed to obtain the producer from boundary +geometry. It asks normalization/projective-closure arguments to return the +certificate above for the canonical reduced base ideal, but it does not put +the desired support-vanishing conclusion among the certificate fields. + +This is a definition rather than an axiom. Consequently a caller must still +prove the actual completion, homogeneous-equation, and tangent-inclusion +construction; the adapter theorem above cannot discharge those obligations +by circular reasoning. +-/ +def CanonicalBoundaryChartProduction : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → + IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)).Nonempty → + Nonempty (CompletedProjectiveBoundaryChart k (n + 1) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) + +/-- +The exact adapter from global boundary-chart production to the canonical +Laurent producer. All support hypotheses are used only to request a chart; +the chart-to-conormal proof itself has no support-vanishing premise. +-/ +theorem canonicalAsymptoticLaurentProducer_of_boundaryChartProduction + (hproduction : CanonicalBoundaryChartProduction.{u}) : + CanonicalAsymptoticLaurentProducer.{u} := by + intro k _ _ _ n N d hN hd hdisjoint hnonempty + obtain ⟨W⟩ := + hproduction k n N d hN hd hdisjoint hnonempty + obtain ⟨y, xi, hmem, haxis⟩ := + exists_conormalAxis_of_completedProjectiveBoundaryChart + (k := k) (m := n + 1) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) W + exact ⟨y, xi, hmem, haxis⟩ + + +end + +end Stafford38.Geometry.CanonicalAsymptoticLaurentProducer diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalConstantCoordinateBranch.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalConstantCoordinateBranch.lean new file mode 100644 index 0000000000..a626413ed6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalConstantCoordinateBranch.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalBaseVariety +import LeanPool.Stafford38.Stafford38.Geometry.ConstantCoordinateConormal +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalResidueExtension +import Mathlib.RingTheory.Ideal.MinimalPrime.Basic +import Mathlib.RingTheory.Nullstellensatz + +/-! +# Canonical constant-coordinate branch + +If the distinguished coordinate is constant on a minimal component of a +radical affine variety, a minimal-prime multiplier and the Nullstellensatz +produce an ambient equation whose differential is the pure coordinate axis. +This gives the exact residue-extension endpoint used by the canonical +assembly, with residue extension equal to the ground field. +-/ + +namespace Stafford38.Geometry.CanonicalConstantCoordinateBranch + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ConstantCoordinateConormal +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + + +private theorem exists_zero_eval_ne_of_isRadical_not_mem + {k : Type u} [Field k] [IsAlgClosed k] {m : ℕ} + (I : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) + {g : MvPolynomial (Fin m) k} (hg : g ∉ I) : + ∃ y : Fin m → k, + (∀ f ∈ I, MvPolynomial.eval y f = 0) ∧ + MvPolynomial.eval y g ≠ 0 := by + classical + by_contra h + have hall : ∀ y : Fin m → k, + y ∈ MvPolynomial.zeroLocus k I → MvPolynomial.eval y g = 0 := by + intro y hy + by_contra hgy + exact h ⟨y, hy, hgy⟩ + have hgvanish : g ∈ MvPolynomial.vanishingIdeal k + (MvPolynomial.zeroLocus k I) := hall + rw [MvPolynomial.vanishingIdeal_zeroLocus_eq_radical, hI.radical] at hgvanish + exact hg hgvanish + +/-- A coordinate which is constant on one minimal component of a radical +affine variety already contributes the pure coordinate covector to the +ambient equation-defined conormal at a suitable point. The multiplier is +the standard zero-divisor witness for a minimal prime; radicality and the +Nullstellensatz choose a point where that multiplier does not vanish. -/ +theorem exists_ambientConormalAxis_of_minimalPrime_coordinate_constant + {k : Type u} [Field k] [IsAlgClosed k] {m : ℕ} + (I P : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) + (hP : P ∈ I.minimalPrimes) (i : Fin m) (c : k) + (hconstant : MvPolynomial.X i - MvPolynomial.C c ∈ P) : + ∃ y : Fin m → k, + (∀ f ∈ I, MvPolynomial.eval y f = 0) ∧ + coordinateCovector (fun j ↦ if j = i then 1 else 0) ∈ + affineConormalSpace y I := by + classical + let h : MvPolynomial (Fin m) k := + MvPolynomial.X i - MvPolynomial.C c + obtain ⟨g, hgI, hhg⟩ := + Ideal.exists_mul_mem_of_mem_minimalPrimes hP hconstant + obtain ⟨y, hy, hgy⟩ := + exists_zero_eval_ne_of_isRadical_not_mem I hI hgI + have hhzero : MvPolynomial.eval y h = 0 := by + have hproduct : MvPolynomial.eval y (h * g) = 0 := hy _ hhg + rw [map_mul] at hproduct + exact (mul_eq_zero.mp hproduct).resolve_right hgy + have hdiff : differentialCovector y (h * g) = + MvPolynomial.eval y g • + coordinateCovector (fun j ↦ if j = i then 1 else 0) := by + apply LinearMap.ext + intro v + change (∑ j, differentialAt y (h * g) j * v j) = + MvPolynomial.eval y g * + ∑ j, (if j = i then 1 else 0) * v j + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j hj + by_cases hji : j = i + · subst j + simp [differentialAt, MvPolynomial.pderiv_mul, h, hhzero, + mul_assoc, mul_left_comm, mul_comm] + · simp [differentialAt, MvPolynomial.pderiv_mul, h, hhzero, + hji, Ne.symm hji, mul_assoc, mul_left_comm, mul_comm] + have hproductConormal : differentialCovector y (h * g) ∈ + affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan] + apply Submodule.subset_span + exact ⟨⟨h * g, hhg⟩, rfl⟩ + refine ⟨y, hy, ?_⟩ + have hscaled := (affineConormalSpace y I).smul_mem + (MvPolynomial.eval y g)⁻¹ hproductConormal + rw [hdiff] at hscaled + simpa [hgy] using hscaled + +/-- The minimal-component constant-coordinate branch reaches the exact +residue-extension endpoint used by the canonical asymptotic assembly. The +extension is again `K = k`; the only extra ingredient beyond the ambient +branch is the minimal-prime multiplier argument above. -/ +theorem exists_residueExtensionConormalAxis_of_minimalPrime_coordinate_constant + {k : Type u} [Field k] [IsAlgClosed k] {m : ℕ} (hm : 0 < m) + (I P : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) + (hP : P ∈ I.minimalPrimes) (c : k) + (hconstant : MvPolynomial.X ⟨0, hm⟩ - MvPolynomial.C c ∈ P) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin m → LaurentSeries K) + (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + classical + let i : Fin m := ⟨0, hm⟩ + let h : MvPolynomial (Fin m) k := + MvPolynomial.X i - MvPolynomial.C c + obtain ⟨g, hgI, hhg⟩ := + Ideal.exists_mul_mem_of_mem_minimalPrimes hP hconstant + obtain ⟨y, hy, hgy⟩ := + exists_zero_eval_ne_of_isRadical_not_mem I hI hgI + have hhzero : MvPolynomial.eval y h = 0 := by + have hproduct : MvPolynomial.eval y (h * g) = 0 := hy _ hhg + rw [map_mul] at hproduct + exact (mul_eq_zero.mp hproduct).resolve_right hgy + let yL : Fin m → LaurentSeries k := fun j ↦ + algebraMap k (LaurentSeries k) (y j) + let xi : Fin m → PowerSeries k := fun j ↦ + PowerSeries.C (if j = i then 1 else 0) + let IL := I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) + let fL := scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m) (h * g) + have hyL : ∀ f ∈ IL, MvPolynomial.eval yL f = 0 := by + rw [show (∀ f ∈ IL, MvPolynomial.eval yL f = 0) ↔ + yL ∈ MvPolynomial.zeroLocus (LaurentSeries k) IL by rfl] + rw [mem_zeroLocus_map_iff] + intro f hf + change MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + ((algebraMap k (LaurentSeries k)) ∘ y) f = 0 + rw [← MvPolynomial.eval₂_comp, hy f hf, map_zero] + have hfL : fL ∈ IL := by + exact Ideal.mem_map_of_mem + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) hhg + have hgyL : algebraMap k (LaurentSeries k) (MvPolynomial.eval y g) ≠ 0 := by + simpa only [map_zero] using + (algebraMap k (LaurentSeries k)).injective.ne hgy + have hdiffAtL (j : Fin m) : + differentialAt yL fL j = + algebraMap k (LaurentSeries k) (differentialAt y (h * g) j) := by + rw [differentialAt_scalarPolynomialMap] + change MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + ((algebraMap k (LaurentSeries k)) ∘ y) + (MvPolynomial.pderiv j (h * g)) = _ + rw [← MvPolynomial.eval₂_comp] + rfl + have hdiffL : differentialCovector yL fL = + algebraMap k (LaurentSeries k) (MvPolynomial.eval y g) • + coordinateCovector + (fun j : Fin m ↦ if j = i then 1 else 0) := by + apply LinearMap.ext + intro v + change (∑ j, differentialAt yL fL j * v j) = + algebraMap k (LaurentSeries k) (MvPolynomial.eval y g) * + ∑ j, (if j = i then 1 else 0) * v j + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j hj + rw [hdiffAtL] + by_cases hji : j = i + · subst j + simp [h, differentialAt, MvPolynomial.pderiv_mul, hhzero, + mul_assoc, mul_left_comm, mul_comm] + · simp [h, differentialAt, MvPolynomial.pderiv_mul, hhzero, + hji, Ne.symm hji, mul_assoc, mul_left_comm, mul_comm] + have haxisConormal : coordinateCovector + (fun j : Fin m ↦ if j = i then 1 else 0) ∈ + affineConormalSpace yL IL := by + have hproductConormal : differentialCovector yL fL ∈ + affineConormalSpace yL IL := by + rw [affineConormalSpace_eq_equationCovectorSpan] + apply Submodule.subset_span + exact ⟨⟨fL, hfL⟩, rfl⟩ + have hscaled := (affineConormalSpace yL IL).smul_mem + ((algebraMap k (LaurentSeries k) (MvPolynomial.eval y g))⁻¹ : + LaurentSeries k) hproductConormal + rw [hdiffL] at hscaled + simpa only [inv_smul_smul₀ hgyL] using hscaled + have hphase : Sum.elim yL + (fun j : Fin m ↦ if j = i then 1 else 0) ∈ + equationConormalLocus IL := ⟨hyL, haxisConormal⟩ + refine ⟨k, inferInstance, inferInstance, yL, xi, ?_, ?_⟩ + · change Sum.elim yL + (fun j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi j)) ∈ + groundEquationConormalLocus (k := k) (K := k) I + simpa [xi, i, IL, groundEquationConormalLocus, groundPolynomialMap, + groundLaurentMap, scalarPolynomialMap] using hphase + · funext j + simp [xi, i, residueColumn] + +/-- An ambient constant-coordinate equation and one ambient zero produce the +exact existential residue-extension conormal axis. No algebraic closure, +boundary valuation, or nonconstant-coordinate argument is needed. -/ +theorem exists_residueExtensionConormalAxis_of_ambientCoordinate_constant + {k : Type u} [Field k] {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (hexists : ∃ y : Fin m → k, + ∀ f ∈ I, MvPolynomial.eval y f = 0) + (hconstant : ∃ c : k, + MvPolynomial.X ⟨0, hm⟩ - MvPolynomial.C c ∈ I) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin m → LaurentSeries K) + (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + obtain ⟨y, hy⟩ := hexists + obtain ⟨c, hc⟩ := hconstant + obtain ⟨yL, xi, hphase, hresidue⟩ := + exists_laurentConormalAxis_of_coordinate_sub_constant_mem + I y hy ⟨0, hm⟩ c hc + refine ⟨k, inferInstance, inferInstance, yL, xi, ?_, hresidue⟩ + simpa [groundEquationConormalLocus, groundPolynomialMap, groundLaurentMap, + scalarPolynomialMap] using hphase + +/-- Canonical specialization of the ambient constant-coordinate branch. +Nonempty order-characteristic support supplies the required ambient base +zero. The conclusion is exactly the point type consumed by the +higher-dimensional residue-extension assembly. -/ +theorem exists_canonical_residueExtensionConormalAxis_of_baseCoordinate_constant + {k : Type u} [Field k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hsupp : + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)).Nonempty) + (hconstant : ∃ c : k, + MvPolynomial.X ⟨0, Nat.zero_lt_succ n⟩ - MvPolynomial.C c ∈ + reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin (n + 1) → LaurentSeries K) + (xi : Fin (n + 1) → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) ∧ + residueColumn xi = + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) := by + apply exists_residueExtensionConormalAxis_of_ambientCoordinate_constant + (Nat.zero_lt_succ n) + · exact exists_reducedOrderBaseZero_of_support_nonempty + (canonicalRightIdeal (presentedCoordinate k n) d N) hsupp + · exact hconstant + + +end + +end Stafford38.Geometry.CanonicalConstantCoordinateBranch diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalFiniteGradientProjectiveCoordinates.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalFiniteGradientProjectiveCoordinates.lean new file mode 100644 index 0000000000..f4620c3c41 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalFiniteGradientProjectiveCoordinates.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ComponentFunctionFieldBoundary +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosureNormalization +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveOrder +import LeanPool.Stafford38.Stafford38.Geometry.RetainedProjectiveCompletion + +/-! +# Exact normalized projective coordinates at a retained boundary place + +This file is a small, theorem-only adapter for the finite-gradient geometry +route. It keeps the residue field and the completed-DVR map supplied by the +retained place, and records the projective normalization, the distinguished +coordinate ratio, and the two zero-residue facts needed by downstream +certificates. +-/ + +namespace Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates + +open IsLocalRing +open Stafford38.Characteristic +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveClosureNormalization +open Stafford38.Geometry.ComponentProjectiveOrder +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedProjectiveCompletion +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +/- The common-scale equation is retained explicitly: this is the bridge used +by the homogeneous-equation transport theorem, rather than an opaque +membership assertion about a projective closure. -/ +theorem exists_completed_normalized_projective_coordinates + {k : Type u} [Field k] [CharZero k] [IsAlgClosed k] {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (P : PrimeSpectrum (MvPolynomial (Fin n) k)) + (hBP : reducedOrderBaseIdeal k I ≤ P.asIdeal) + (hi : Transcendental k (componentCoordinate P i)) : + ∃ W : Data k (ComponentFractionField P) (componentCoordinate P i), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + ∃ (chart : Fin (n + 1)) + (q : Fin (n + 1) → W.place.valuation.toSubring) + (scale : ComponentFractionField P), + scale ≠ 0 ∧ q chart = 1 ∧ q 0 ≠ 0 ∧ + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ i) = q 0 * W.place.parameter ∧ + (let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + let qhat := fun a ↦ retainedToCompletedPowerSeries W (q a) + let ratio := retainedToCompletedPowerSeries W W.place.parameter + qhat chart = 1 ∧ qhat 0 ≠ 0 ∧ ratio ≠ 0 ∧ + PowerSeries.constantCoeff (qhat 0) = 0 ∧ + PowerSeries.constantCoeff ratio = 0 ∧ + qhat (Fin.succ i) = qhat 0 * ratio) := by + obtain ⟨W, chart, q, scale, hscale, hchart, hzero, hq, hratio⟩ := + exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace P i hi + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + have hzero_nonunit : ¬IsUnit (q 0) := + normalizedComponentProjectivePoint_zero_nonunit + I i hdisjoint P hBP W q scale hq + refine ⟨W, chart, q, scale, hscale, hchart, hzero, hq, hratio, ?_⟩ + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact retainedCompleted_projective_order_properties W (ι := Fin (n + 1)) + (q := q) (chart := chart) (zero := 0) (axis := Fin.succ i) + hchart hzero hzero_nonunit hratio + + +end + +end Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProduction.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProduction.lean new file mode 100644 index 0000000000..ca3490b6f8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProduction.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalConstantCoordinateBranch +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalResidueExtensionAssembly +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension + +/-! +# Canonical finite-gradient production + +The terminal residue-extension consumer needs only one finite gradient +conormal row. This file records the corresponding weaker nonconstant +component interface and adapts it to the existing component-split assembly. +The actual construction of the finite-gradient certificate remains a separate +geometric problem. +-/ + +namespace Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.CanonicalConstantCoordinateBranch +open Stafford38.Geometry.CanonicalResidueExtensionAssembly +open Stafford38.Geometry.FiniteGradientResidueExtension +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +/-- The nonconstant component interface with the weakest certificate needed by +the terminal conormal-axis consumer. -/ +def HigherDimensionalCanonicalResidueExtensionNonconstantFiniteGradientProduction : + Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < n → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + ∀ P : PrimeSpectrum (MvPolynomial (Fin (n + 1)) k), + P.asIdeal ∈ + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).minimalPrimes → + Transcendental k + (componentCoordinate P ⟨0, Nat.zero_lt_succ n⟩) → + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K), + Nonempty + (FiniteGradientBoundaryCertificateOver + (k := k) (K := K) (n + 1) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) + +/-- A finite-gradient certificate on the transcendental component supplies the +exact conormal axis consumed by the residue-extension assembly. The +constant-coordinate component is handled by the existing ground-field branch. +-/ +theorem higherDimensionalCanonicalResidueExtensionConormalAxisProduction_of_nonconstantFiniteGradient + (hnonconstant : + HigherDimensionalCanonicalResidueExtensionNonconstantFiniteGradientProduction.{u}) : + HigherDimensionalCanonicalResidueExtensionConormalAxisProduction.{u} := by + intro k _ _ _ n N d hn hN hd hdisjoint hsupp + let I := reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N) + have hproper : I ≠ ⊤ := + reducedOrderBaseIdeal_ne_top_of_support_nonempty + (canonicalRightIdeal (presentedCoordinate k n) d N) hsupp + obtain ⟨P, hP, hIP, hconstant | htranscendental⟩ := + exists_minimalPrime_coordinate_constant_or_transcendental + I hproper ⟨0, Nat.zero_lt_succ n⟩ + · obtain ⟨c, hc⟩ := hconstant + exact + exists_residueExtensionConormalAxis_of_minimalPrime_coordinate_constant + (Nat.zero_lt_succ n) I P.asIdeal + (reducedOrderBaseIdeal_isRadical k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + hP c hc + · obtain ⟨K, fieldK, algebraK, W⟩ := + hnonconstant k n N d hn hdisjoint P hP htranscendental + letI : Field K := fieldK + letI : Algebra k K := algebraK + letI : CharZero K := + charZero_of_injective_algebraMap (algebraMap k K).injective + obtain ⟨y, xi, hgeneric, hresidue⟩ := + exists_groundConormalAxis_of_finiteGradientBoundaryCertificateOver + (k := k) (K := K) (Nat.zero_lt_succ n) I W.some + exact ⟨K, fieldK, algebraK, y, xi, hgeneric, hresidue⟩ + + +end + +end Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProductionProof.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProductionProof.lean new file mode 100644 index 0000000000..dbabff97b0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalNonconstantFiniteGradientProductionProof.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientBoundaryProducer +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientFromTangentInclusion + +/-! +# The first explicit boundary producer interface + +The retained-place and normalized-projective-coordinate files already produce +the completed projective arc. The remaining geometric input is only one +regular affine conormal row on that arc. This file records that input as an +ordinary structure and proves the exact finite-gradient certificate consumed +by the residue-extension endgame. + +The structure is deliberately not an axiom and does not assert that such a +row exists. Its `conormal` field is the first open bridge in the nonconstant +boundary construction. The theorem below is the trust-zero adapter from +that bridge to the finite equation/gradient certificate. +-/ + +namespace Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.FiniteGradientBoundaryProducer +open Stafford38.Geometry.FiniteGradientFromTangentInclusion +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.FiniteGradientResidueExtension +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.PointwiseConormalContainment +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-- The exact one-row datum still needed after the normalized retained-place +construction. In particular, `conormal` is an explicit affine statement at +the completed Laurent point; it is not inferred from a tangent-space slogan. + +The projective and residue fields are retained because they are part of the +boundary certificate, even though the affine conormal extractor below uses +only the displayed `conormal` field to find finite gradient coefficients. -/ +structure RegularizedOneRowConormalData + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin (m + 1) → PowerSeries K) where + ell : Fin (m + 1) → PowerSeries K + q_origin_ne : q 0 ≠ 0 + projective_annihilation : + ∑ i, laurentColumn ell i * laurentColumn q i = 0 + base_vanish : + ∀ f ∈ I.map (groundPolynomialMap (k := k) (K := K) (Fin m)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0 + conormal : + coordinateCovector (fun i ↦ laurentColumn ell i.succ) ∈ + affineConormalSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (groundPolynomialMap (k := k) (K := K) (Fin m))) + residue_axis : + residueColumn (fun i : Fin m ↦ ell i.succ) = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) + +/-- A regularized one-row conormal datum yields the finite gradient certificate +over the same residue-field extension. The only mathematical input is the +explicit `RegularizedOneRowConormalData`; all finite equations and Laurent +coefficients are extracted by the checked affine conormal-span theorem. -/ +theorem finiteGradientBoundaryCertificateOver_of_regularizedOneRowConormalData + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin (m + 1) → PowerSeries K) + (W : RegularizedOneRowConormalData (k := k) (K := K) hm I q) : + Nonempty (FiniteGradientBoundaryCertificateOver + (k := k) (K := K) m hm I) := by + let Iext := I.map + (groundPolynomialMap (k := k) (K := K) (Fin m)) + let y := dehomogenizedPoint (laurentColumn q) + let xi : Fin m → LaurentSeries K := + fun i ↦ laurentColumn W.ell i.succ + obtain ⟨r, equations, coefficients, hgradient⟩ := + exists_fin_gradient_identity_of_mem_affineConormalSpace + Iext y xi W.conormal + exact ⟨{ + equationCount := r + q := q + ell := W.ell + q_origin_ne := W.q_origin_ne + projective_annihilation := W.projective_annihilation + base_vanish := W.base_vanish + equations := equations + coefficients := coefficients + gradient_identity := by + intro i + exact hgradient i + residue_axis := W.residue_axis + }⟩ + +/-- The finite-gradient certificate immediately supplies the terminal +conormal-axis witness. This is a named adapter so a future retained-place +producer can target the smaller row datum directly. -/ +theorem exists_groundConormalAxis_of_regularizedOneRowConormalData + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin (m + 1) → PowerSeries K) + (W : RegularizedOneRowConormalData (k := k) (K := K) hm I q) : + ∃ (y : Fin m → LaurentSeries K) + (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + obtain ⟨certificate⟩ := + finiteGradientBoundaryCertificateOver_of_regularizedOneRowConormalData + (k := k) (K := K) hm I q W + exact exists_groundConormalAxis_of_finiteGradientBoundaryCertificateOver + (k := k) (K := K) hm I certificate + + +end + +end Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalResidueExtensionAssembly.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalResidueExtensionAssembly.lean new file mode 100644 index 0000000000..6023bac54f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalResidueExtensionAssembly.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalLaurentSymbolControl +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.OneVariableAmbientConormal + +/-! +# Canonical geometry over the boundary residue field + +The residue field `K` of a projective boundary divisor need not equal the +ground field `k`. The completed arc therefore lives in `K[[t]]`, while the +canonical Weyl operator, its principal symbol, and the contracted base ideal +remain defined over `k`. + +This file repairs the terminal rank split at that interface. In ambient rank +one the existing direct argument stays over `k`. In higher rank the producer +is allowed to choose an arbitrary extension field `K/k` and returns the +Laurent conormal point actually consumed by the symbol contradiction. It may +obtain that point directly from a constant-coordinate component or from a +completed boundary chart. Symbol vanishing is requested over the same chosen +extension, and the contradiction is completed there. No map `K → k` +occurs. + +The results are conditional assemblers. They do not produce the +higher-dimensional conormal axis, prove post-extension Poisson/Gabber +integrability, prove noncharacteristic restriction, or prove the canonical +coordinate-preimage hypothesis. +-/ + +namespace Stafford38.Geometry.CanonicalResidueExtensionAssembly + +open Stafford38 +open Stafford38.CanonicalAxisAvoidanceConsumer +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalLaurentSymbolControl +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.CanonicalUnitCoordinatePreimage +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ConormalAxisContradiction +open Stafford38.Geometry.FiniteGradientResidueExtension +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.OneVariableAmbientConormal +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization +open Stafford38.WeylEulerResidue +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +/-! ## Exact conditional inputs -/ + +/-- Symbol control after extension to the Laurent field of an arbitrary +residue extension `K/k`. + +This is the exact geometric-support input used below. It is deliberately not +called a theorem of Gabber: a caller must still prove it for the concrete +canonical quotient and the particular extension selected by boundary +geometry. -/ +def CanonicalResidueExtensionSymbolControl : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (K : Type u) [Field K] [Algebra k K] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + ∃ P : MvPolynomial (Fin (n + 1)) k, + fibreLift P = presentedPrincipalComponent k orderWeight N d ∧ + ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)), + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = 0 + +/-- Higher-dimensional production of the exact conormal-axis endpoint used by +the symbol contradiction, over its natural existential residue extension. + +The strict inequality excludes ambient rank one, which is handled directly. +In higher rank this interface deliberately does not prescribe how the point is +produced: the constant-coordinate branch may take `K = k`, while the +nonconstant branch may extract it from a completed boundary chart over a +genuine residue extension. -/ +def HigherDimensionalCanonicalResidueExtensionConormalAxisProduction : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < n → + 0 < N → + IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)).Nonempty → + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin (n + 1) → LaurentSeries K) + (xi : Fin (n + 1) → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) ∧ + residueColumn xi = + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) + +/-! ## One chart gives the terminal contradiction over `K` -/ + +/-- The canonical principal symbol evaluates to one on the pure first-fibre +axis before and after extension from `k` to `K`. -/ +theorem canonical_fibrePolynomial_eval_extensionAxis + {k K : Type u} [Field k] [Field K] [Algebra k K] + {n N : ℕ} {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (P : MvPolynomial (Fin (n + 1)) k) + (hP : fibreLift P = presentedPrincipalComponent k orderWeight N d) : + MvPolynomial.eval₂ (algebraMap k K) + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) P = 1 := by + have hcanonical := + canonical_orderPrincipalComponent_eval_pureMomentumAxis n N hd + have hsplit : + Sum.elim (fun _ : Fin (n + 1) ↦ (0 : k)) + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) = + axisPoint k (.inr (0 : Fin (n + 1))) := by + funext i + rcases i with i | i + · simp [axisPoint] + · simp [axisPoint] <;> rfl + rw [← hP] at hcanonical + have heval := eval₂_fibreLift (K := k) P + (fun _ : Fin (n + 1) ↦ (0 : k)) + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) + rw [hsplit] at heval + have hground : MvPolynomial.eval + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) P = 1 := by + simpa only [← MvPolynomial.aeval_def, MvPolynomial.aeval_eq_eval] using + heval.symm.trans hcanonical + rw [eval₂_extensionAxis_eq_algebraMap_eval_axis + (K := K) (Nat.zero_lt_succ n) P, hground] + exact map_one (algebraMap k K) + +/-- A residue-extension completed chart, together with canonical symbol +vanishing over the same Laurent field, is contradictory. The conclusion is +proved in `K`; no residue-field descent or retraction is used. -/ +theorem false_of_canonical_completedProjectiveBoundaryChartOver + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (P : MvPolynomial (Fin (n + 1)) k) + (hP : fibreLift P = presentedPrincipalComponent k orderWeight N d) + (W : CompletedProjectiveBoundaryChartOver + (k := k) (K := K) (n + 1) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) + (hvanishes : + ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)), + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = 0) : False := by + letI : CharZero K := + charZero_of_injective_algebraMap (algebraMap k K).injective + obtain ⟨y, xi, hgeneric, hresidue⟩ := + exists_conormalAxis_of_completedProjectiveBoundaryChartOver + (k := k) (K := K) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) W + exact false_of_ground_fibreOnly_symbol_one_on_residue_and_vanishing + (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + P + (fun i : Fin (n + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) + y xi hgeneric hresidue hvanishes + (canonical_fibrePolynomial_eval_extensionAxis + (K := K) hd P hP) + +/-! ## Rank-split terminal assembly -/ + +/-- Conditional support vanishing with the corrected coefficient fields. + +The rank-one branch uses the existing direct ambient conormal theorem over +`k`. In the successor branch, conormal-axis production chooses `K/k`; symbol +control and that point are then consumed over precisely that `K`. The theorem +never specializes a `K`-valued point to `k[[t]]`. -/ +theorem algebraicallyClosedCanonicalSupportVanishing_of_residueExtension_rankSplit + (hunit : CanonicalStrictUnitCoordinatePreimage.{u}) + (hcontrol : CanonicalResidueExtensionSymbolControl.{u}) + (hproduction : + HigherDimensionalCanonicalResidueExtensionConormalAxisProduction.{u}) : + AlgebraicallyClosedCanonicalSupportVanishing.{u} := by + intro k _ _ _ n N d hN hd + let I := canonicalRightIdeal (presentedCoordinate k n) d N + have hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := + canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus_of_strictUnit + k n N (hunit k n N d hN hd) + by_contra hsupp + have hnonempty : (orderCharacteristicSupport k I).Nonempty := + Set.nonempty_iff_ne_empty.mpr hsupp + cases n with + | zero => + obtain ⟨P, hP, hvanishes⟩ := hcontrol k k 0 N d hN hd + obtain ⟨y, xi, hgeneric, hresidue⟩ := + exists_canonical_rankOne_laurentConormalAxis I hdisjoint hnonempty + apply false_of_ground_fibreOnly_symbol_one_on_residue_and_vanishing + (k := k) (K := k) (reducedOrderBaseIdeal k I) P + (fun _ : Fin 1 ↦ (1 : k)) y xi + · simpa [groundEquationConormalLocus, groundPolynomialMap, + groundLaurentMap, scalarPolynomialMap] using hgeneric + · exact hresidue + · exact hvanishes + · have haxis := canonical_fibrePolynomial_eval_extensionAxis + (K := k) hd P hP + have hfun : (fun _ : Fin 1 ↦ (1 : k)) = + (fun i : Fin 1 ↦ + if i = ⟨0, Nat.zero_lt_succ 0⟩ then 1 else 0) := by + funext i + fin_cases i + simp + rw [hfun] + exact haxis + | succ n => + obtain ⟨K, fieldK, algebraK, y, xi, hgeneric, hresidue⟩ := + hproduction k (n + 1) N d (Nat.zero_lt_succ n) + hN hd hdisjoint hnonempty + letI : Field K := fieldK + letI : Algebra k K := algebraK + obtain ⟨P, hP, hvanishes⟩ := + hcontrol k K (n + 1) N d hN hd + exact false_of_ground_fibreOnly_symbol_one_on_residue_and_vanishing + (k := k) (K := K) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k (n + 1)) d N)) + P + (fun i : Fin ((n + 1) + 1) ↦ + if i = ⟨0, Nat.zero_lt_succ (n + 1)⟩ then 1 else 0) + y xi hgeneric hresidue hvanishes + (canonical_fibrePolynomial_eval_extensionAxis + (K := K) hd P hP) + + +end + +end Stafford38.Geometry.CanonicalResidueExtensionAssembly diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CanonicalVisibleDivisorFrameProduction.lean b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalVisibleDivisorFrameProduction.lean new file mode 100644 index 0000000000..b7c5d730ff --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CanonicalVisibleDivisorFrameProduction.lean @@ -0,0 +1,297 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +import LeanPool.Stafford38.Stafford38.Geometry.GenericPointKaehlerConormal +import LeanPool.Stafford38.Stafford38.Geometry.RetainedPlaceConormalTransport + +/-! +# Lane C reduced to a visible divisor frame + +The finite-gradient interface of lane C asks, on every minimal component +whose distinguished coordinate is transcendental, for one finite-gradient +boundary certificate over some field extension. This file reduces that +interface to a single geometric statement: the existence of a retained +boundary place whose normalized homogeneous coordinate column carries a +*visible divisor frame* in the sense of `DivisorTangentLattice`. + +Everything downstream is trust-zero: + +* the lattice lemma turns the visible frame into a Kähler relation with + coefficients divisible by `t^(a+e-1)`; +* the generic-point bridge turns that relation into affine conormal + membership at the generic point; +* the retained-place transport carries it to the completed residue field, + supplies the projective zeroth entry, and produces the one-row datum; +* the existing adapter extracts the finite-gradient certificate. + +Nothing here constructs the place or the frame. The producer statement +`HigherDimensionalCanonicalVisibleDivisorFrameProduction` is the exact +remaining geometric input of lane C. +-/ + +namespace Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +open Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.DivisorTangentLattice +open Stafford38.Geometry.FiniteGradientResidueExtension +open Stafford38.Geometry.GenericPointKaehlerConormal +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedGroundMapIdentification +open Stafford38.Geometry.RetainedPlaceConormalTransport +open Stafford38.Geometry.RetainedProjectiveCompletion +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open IsLocalRing + +noncomputable section + +universe u + + +variable {k : Type u} [Field k] {m : ℕ} + +/-! ## Conormal transfer from a minimal prime to the radical ideal -/ + +section Transfer + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation + +variable {F : Type*} [Field F] + +theorem differentialCovector_mul (y : Fin m → F) (p q : MvPolynomial (Fin m) F) : + differentialCovector y (p * q) = + MvPolynomial.eval y q • differentialCovector y p + + MvPolynomial.eval y p • differentialCovector y q := by + apply LinearMap.ext + intro v + change (∑ i, differentialAt y (p * q) i * v i) = + MvPolynomial.eval y q * (∑ i, differentialAt y p i * v i) + + MvPolynomial.eval y p * (∑ i, differentialAt y q i * v i) + simp only [differentialAt, MvPolynomial.pderiv_mul, map_add, map_mul, Finset.mul_sum, + ← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + ring + +theorem differentialCovector_add (y : Fin m → F) (p q : MvPolynomial (Fin m) F) : + differentialCovector y (p + q) = differentialCovector y p + differentialCovector y q := by + apply LinearMap.ext + intro v + change (∑ i, differentialAt y (p + q) i * v i) = + (∑ i, differentialAt y p i * v i) + ∑ i, differentialAt y q i * v i + simp only [differentialAt, map_add, add_mul, Finset.sum_add_distrib] + +theorem differentialCovector_zero (y : Fin m → F) : + differentialCovector y (0 : MvPolynomial (Fin m) F) = 0 := by + apply LinearMap.ext + intro v + change (∑ i, differentialAt y 0 i * v i) = 0 + simp [differentialAt] + +/-- For a radical ideal `I` and a minimal prime `P` of `I`, every element of +`P` becomes an element of `I` after multiplication by an element outside `P`. +The multiplier is a product of elements of the other minimal primes. -/ +theorem exists_mul_mem_of_mem_minimalPrimes_of_isRadical + {R : Type*} [CommRing R] [IsNoetherianRing R] + {I P : Ideal R} (hI : I.IsRadical) (hP : P ∈ I.minimalPrimes) + {f : R} (hf : f ∈ P) : ∃ s ∉ P, s * f ∈ I := by + classical + have hfin := Ideal.finite_minimalPrimes_of_isNoetherianRing R I + set T := hfin.toFinset.erase P with hT + have hchoice : ∀ Q ∈ T, ∃ s ∈ Q, s ∉ P := by + intro Q hQ + rw [hT, Finset.mem_erase, hfin.mem_toFinset] at hQ + by_contra hcon + push_neg at hcon + exact hQ.1 (le_antisymm hcon (hP.2 hQ.2.1 hcon)) + choose s hsQ hsP using hchoice + refine ⟨∏ Q ∈ T.attach, s Q.1 Q.2, ?_, ?_⟩ + · intro h + obtain ⟨Q, -, hQ⟩ := (hP.1.1.prod_mem_iff).1 h + exact hsP Q.1 Q.2 hQ + · rw [← hI.radical, ← Ideal.sInf_minimalPrimes, Ideal.mem_sInf] + intro Q hQ + by_cases hQP : Q = P + · subst hQP + exact Ideal.mul_mem_left _ _ hf + · have hQT : Q ∈ T := by + rw [hT, Finset.mem_erase, hfin.mem_toFinset] + exact ⟨hQP, hQ⟩ + refine Ideal.mul_mem_right _ _ ?_ + exact Ideal.mem_of_dvd _ + (Finset.dvd_prod_of_mem (fun Q : T ↦ s Q.1 Q.2) (Finset.mem_attach _ ⟨Q, hQT⟩)) + (hsQ Q hQT) + +/-- At a point whose vanishing ideal is exactly the minimal prime `P` of `I`, +the equation-defined conormal space of `P` is contained in that of `I`. -/ +theorem affineConormalSpace_map_minimalPrime_le [Algebra k F] + (I P : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) (hP : P ∈ I.minimalPrimes) + (y : Fin m → F) + (hy : ∀ f, MvPolynomial.eval y (MvPolynomial.map (algebraMap k F) f) = 0 ↔ f ∈ P) : + affineConormalSpace y (P.map (MvPolynomial.map (algebraMap k F))) ≤ + affineConormalSpace y (I.map (MvPolynomial.map (algebraMap k F))) := by + classical + rw [affineConormalSpace_eq_equationCovectorSpan, affineConormalSpace_eq_equationCovectorSpan] + set S := equationCovectorSpan y (I.map (MvPolynomial.map (algebraMap k F))) + refine Submodule.span_le.2 ?_ + rintro _ ⟨⟨f', hf'⟩, rfl⟩ + show differentialCovector y f' ∈ S + have key : MvPolynomial.eval y f' = 0 ∧ differentialCovector y f' ∈ S := by + refine Submodule.span_induction (p := fun x _ ↦ + MvPolynomial.eval y x = 0 ∧ differentialCovector y x ∈ S) ?_ ?_ ?_ ?_ hf' + · rintro _ ⟨f, hf, rfl⟩ + refine ⟨(hy f).2 hf, ?_⟩ + obtain ⟨g, hgP, hfg⟩ := exists_mul_mem_of_mem_minimalPrimes_of_isRadical hI hP hf + have hg : MvPolynomial.eval y (MvPolynomial.map (algebraMap k F) g) ≠ 0 := + fun h ↦ hgP ((hy g).1 h) + have hprod : differentialCovector y + (MvPolynomial.map (algebraMap k F) (g * f)) ∈ S := + Submodule.subset_span ⟨⟨_, Ideal.mem_map_of_mem _ hfg⟩, rfl⟩ + rw [map_mul, differentialCovector_mul, (hy f).2 hf, zero_smul, zero_add] at hprod + have := S.smul_mem (MvPolynomial.eval y (MvPolynomial.map (algebraMap k F) g))⁻¹ hprod + rwa [smul_smul, inv_mul_cancel₀ hg, one_smul] at this + · exact ⟨by simp, by rw [differentialCovector_zero]; exact S.zero_mem⟩ + · rintro x y' _ _ ⟨hx0, hx⟩ ⟨hy0, hy'⟩ + exact ⟨by rw [map_add, hx0, hy0, add_zero], + by rw [differentialCovector_add]; exact S.add_mem hx hy'⟩ + · rintro p x _ ⟨hx0, hx⟩ + refine ⟨by rw [smul_eq_mul, map_mul, hx0, mul_zero], ?_⟩ + rw [smul_eq_mul, differentialCovector_mul, hx0, zero_smul, zero_add] + exact S.smul_mem _ hx + exact key.2 + +end Transfer + +/-- A retained boundary place on a component together with a normalized +projective column and a visible divisor frame attached to it. -/ +def HasVisibleDivisorFrame + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + [CharZero k] : Prop := + ∃ W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + ∃ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + q 0 ≠ 0 ∧ + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter ∧ + ∃ D : VisibleDivisorFrame (V := V) + (KaehlerDifferential.D k (ComponentFractionField P)) (Fin m), + D.Q₀ = q 0 ∧ D.Q₁ = q (Fin.succ ⟨0, hm⟩) ∧ ∀ j, D.Q j = q (Fin.succ j) + +/-- The generic-point bridge instantiated on a component: its statement is +the `hbridge` hypothesis of the retained-place transport. -/ +theorem component_kaehler_bridge (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (xi : Fin m → ComponentFractionField P) + (h : ∑ j, xi j • KaehlerDifferential.D k (ComponentFractionField P) + (componentCoordinate P j) = 0) : + Stafford38.Geometry.AffineConormalSpan.coordinateCovector xi ∈ + Stafford38.Geometry.AffineConormalSpan.affineConormalSpace (componentCoordinate P) + (P.asIdeal.map (MvPolynomial.map + (algebraMap k (ComponentFractionField P)))) := by + haveI : P.asIdeal.IsPrime := P.isPrime + exact coordinateCovector_mem_affineConormalSpace_of_kaehler_sum_eq_zero + (I := P.asIdeal) (F := ComponentFractionField P) xi h + +/-- A visible divisor frame on a component yields a finite-gradient boundary +certificate over the residue field of its place, for the radical ideal of +which the component is a minimal prime. -/ +theorem exists_finiteGradientBoundaryCertificateOver_of_hasVisibleDivisorFrame + [CharZero k] + (I : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hP : P.asIdeal ∈ I.minimalPrimes) + (hm : 0 < m) (h : HasVisibleDivisorFrame P hm) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K), + Nonempty (FiniteGradientBoundaryCertificateOver (k := k) (K := K) m hm I) := by + classical + obtain ⟨W, q, scale, hq0, hq, hratio, D, hQ₀, hQ₁, hQ⟩ := h + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := retainedResidueGroundAlgebra P ⟨0, hm⟩ W + -- The generic point kills exactly the minimal prime. + have hy : ∀ f, MvPolynomial.eval (componentCoordinate P) + (MvPolynomial.map (algebraMap k (ComponentFractionField P)) f) = 0 ↔ f ∈ P.asIdeal := by + intro f + rw [MvPolynomial.eval_map, ← componentAffineGenericPointMap_eq_eval₂, + ← RingHom.mem_ker, componentAffineGenericPointMap_ker] + have hbridge : ∀ xi : Fin m → ComponentFractionField P, + ∑ j, xi j • KaehlerDifferential.D k (ComponentFractionField P) + (componentCoordinate P j) = 0 → + Stafford38.Geometry.AffineConormalSpan.coordinateCovector xi ∈ + Stafford38.Geometry.AffineConormalSpan.affineConormalSpace (componentCoordinate P) + (I.map (MvPolynomial.map (algebraMap k (ComponentFractionField P)))) := + fun xi hxi ↦ affineConormalSpace_map_minimalPrime_le I P.asIdeal hI hP _ hy + (component_kaehler_bridge P xi hxi) + have hq0F : (q 0 : ComponentFractionField P) ≠ 0 := fun h ↦ hq0 (Subtype.ext h) + have hIy : ∀ g ∈ I, + MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (componentCoordinate P) g = 0 := by + intro g hg + rw [← componentAffineGenericPointMap_eq_eval₂] + exact componentAffineGenericPointMap_eq_zero_of_mem P (hP.1.2 hg) + obtain ⟨R⟩ := regularizedOneRowConormalData_of_transport hm I (componentCoordinate P) + hIy Subtype.val_injective (retainedToCompletedPowerSeries W) + (retainedToCompletedPowerSeries_injective W) + (retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit W) + (retainedLaurentLift P ⟨0, hm⟩ W) + (retainedLaurentLift_algebraMap P ⟨0, hm⟩ W) + (retainedLaurentLift_comp_algebraMap P ⟨0, hm⟩ W) + q hq0 (componentCoordinate_eq_div P (fun a ↦ (q a : ComponentFractionField P)) + scale hq hq0F) + W.place.parameter hratio D hQ₀ hQ₁ hQ hbridge + exact ⟨ResidueField V, inferInstance, inferInstance, + finiteGradientBoundaryCertificateOver_of_regularizedOneRowConormalData hm I _ R⟩ + +/-- The reduced lane C input: every relevant transcendental component carries +a retained place with a visible divisor frame. -/ +def HigherDimensionalCanonicalVisibleDivisorFrameProduction : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < n → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + ∀ P : PrimeSpectrum (MvPolynomial (Fin (n + 1)) k), + P.asIdeal ∈ + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).minimalPrimes → + Transcendental k (componentCoordinate P ⟨0, Nat.zero_lt_succ n⟩) → + HasVisibleDivisorFrame P (Nat.zero_lt_succ n) + +/-- The visible-frame producer discharges the finite-gradient interface. -/ +theorem higherDimensionalCanonicalResidueExtensionNonconstantFiniteGradientProduction_of_visibleDivisorFrame + (h : HigherDimensionalCanonicalVisibleDivisorFrameProduction.{u}) : + HigherDimensionalCanonicalResidueExtensionNonconstantFiniteGradientProduction.{u} := by + intro k _ _ _ n N d hn hdisjoint P hP htrans + exact exists_finiteGradientBoundaryCertificateOver_of_hasVisibleDivisorFrame _ + (reducedOrderBaseIdeal_isRadical k (canonicalRightIdeal (presentedCoordinate k n) d N)) + P hP (Nat.zero_lt_succ n) (h k n N d hn hdisjoint P hP htrans) + + +end + +end Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ChartArcAnnihilation.lean b/LeanPool/Stafford38/Stafford38/Geometry/ChartArcAnnihilation.lean new file mode 100644 index 0000000000..7c67aa4532 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ChartArcAnnihilation.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticChartArcAdapter + +/-! +# Annihilation by the completed chart arc + +`CompletedProjectiveBoundaryChart` stores affine-ideal containment after +dehomogenizing in coordinate zero, while its normalized power-series chart +coordinate is the unrelated index `chart`. This file makes the necessary +coordinate repair explicit. + +The minimal strengthened certificate below retains the existing completed +chart and asks for the same kind of ideal containment after dehomogenizing in +its actual normalized chart, with precisely the coordinate ordering used by +`completedChartAffineArc`. Projective equation vanishing then proves arc +annihilation; annihilation itself is not a field of the certificate. +-/ + +namespace Stafford38.Geometry.ChartArcAnnihilation + +open Stafford38.Geometry.AsymptoticChartArcAdapter +open Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveBoundaryFrameRank +open Stafford38.Geometry.ScalarExtensionPoints + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +/-- Insert affine coordinates into an arbitrary projective chart, using the +same complement ordering as `completedChartAffineArc`. -/ +def projectiveChartPoint {m : ℕ} (chart : Fin (m + 1)) + (y : Fin m → K) : Fin (m + 1) → K := + fun a ↦ if h : a = chart then 1 + else y ((chartAffineCoordinateEquiv chart).symm ⟨a, h⟩) + +/-- Substitute the chart coordinate by one and the remaining projective +coordinates by the correspondingly ordered affine variables. -/ +def projectiveDehomogenizeAt {m : ℕ} (chart : Fin (m + 1)) : + MvPolynomial (Fin (m + 1)) K →ₐ[K] MvPolynomial (Fin m) K := + MvPolynomial.aeval fun a ↦ if h : a = chart then 1 + else MvPolynomial.X ((chartAffineCoordinateEquiv chart).symm ⟨a, h⟩) + +/-- Evaluation after arbitrary-chart dehomogenization is evaluation at the +inserted projective chart point. -/ +theorem eval_projectiveDehomogenizeAt {m : ℕ} (chart : Fin (m + 1)) + (p : MvPolynomial (Fin (m + 1)) K) (y : Fin m → K) : + MvPolynomial.eval y (projectiveDehomogenizeAt chart p) = + MvPolynomial.eval (projectiveChartPoint chart y) p := by + rw [show projectiveDehomogenizeAt chart p = + MvPolynomial.bind₁ + (fun a ↦ if h : a = chart then 1 + else MvPolynomial.X + ((chartAffineCoordinateEquiv chart).symm ⟨a, h⟩)) p by rfl] + rw [MvPolynomial.hom_bind₁] + change MvPolynomial.eval₂ _ _ p = MvPolynomial.eval₂ _ _ p + have hcoeff : (MvPolynomial.eval y).comp MvPolynomial.C = RingHom.id K := by + ext a + simp + rw [hcoeff] + apply MvPolynomial.eval₂_congr + intro a + by_cases h : a = chart + · subst a + simp [projectiveChartPoint] + · simp [projectiveChartPoint, h] + +/-- The affine ideal generated by dehomogenizing projective equations in the +specified chart. -/ +def chartDehomogenizedEquationIdeal {m : ℕ} {ι : Type*} + (chart : Fin (m + 1)) + (equations : ι → MvPolynomial (Fin (m + 1)) K) : + Ideal (MvPolynomial (Fin m) K) := + Ideal.span (Set.range fun i ↦ projectiveDehomogenizeAt chart (equations i)) + +/-- Every polynomial in the chart-dehomogenized equation ideal vanishes at +an affine chart point whose inserted projective point kills the supplied +projective equations. -/ +theorem eval_eq_zero_of_mem_chartDehomogenizedEquationIdeal + {m : ℕ} {ι : Type*} (chart : Fin (m + 1)) + (equations : ι → MvPolynomial (Fin (m + 1)) K) + (y : Fin m → K) + (hvanish : ∀ i, + MvPolynomial.eval (projectiveChartPoint chart y) (equations i) = 0) + (f : MvPolynomial (Fin m) K) + (hf : f ∈ chartDehomogenizedEquationIdeal chart equations) : + MvPolynomial.eval y f = 0 := by + have hle : chartDehomogenizedEquationIdeal chart equations ≤ + RingHom.ker (MvPolynomial.eval y) := by + apply Ideal.span_le.mpr + rintro _ ⟨i, rfl⟩ + change MvPolynomial.eval y + (projectiveDehomogenizeAt chart (equations i)) = 0 + rw [eval_projectiveDehomogenizeAt] + exact hvanish i + exact hle hf + +/-! ## Minimal completed-chart repair -/ + +/-- A completed projective chart together with affine-ideal containment in +the chart which is actually normalized to one. + +This adds only a chart-relative algebraic containment, parallel to the +coordinate-zero containment already stored in `CompletedProjectiveBoundaryChart`. +It does not assume that the resulting arc annihilates the ideal. -/ +structure ChartArcCompatibleBoundaryChart + (k : Type u) [Field k] [CharZero k] + (m : ℕ) (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) where + toCompleted : CompletedProjectiveBoundaryChart k m hm I + chart_ideal_containment : + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) ≤ + chartDehomogenizedEquationIdeal toCompleted.chart + toCompleted.equations + +/-- Inserting the completed affine chart arc recovers the original +projective Laurent column exactly. -/ +theorem projectiveChartPoint_completedChartAffineArc + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) : + projectiveChartPoint W.chart + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) + (completedChartAffineArc hm I W i)) = + laurentColumn W.q := by + funext a + by_cases h : a = W.chart + · subst a + simp [projectiveChartPoint, laurentColumn, W.q_chart] + · let i : Fin m := + (chartAffineCoordinateEquiv W.chart).symm ⟨a, h⟩ + have hi : chartAffineCoordinateEquiv W.chart i = ⟨a, h⟩ := + (chartAffineCoordinateEquiv W.chart).apply_symm_apply ⟨a, h⟩ + simp [projectiveChartPoint, h, completedChartAffineArc, laurentColumn, + i, hi] + +/-- The minimally repaired completed chart proves, rather than stores, that +its actual power-series affine chart arc annihilates the boundary ideal. -/ +theorem completedChartAffineArc_annihilates + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : ChartArcCompatibleBoundaryChart k m hm I) : + ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries k)) + (completedChartAffineArc hm I W.toCompleted) f = 0 := by + intro f hf + let qLaurent : Fin m → LaurentSeries k := fun i ↦ + algebraMap (PowerSeries k) (LaurentSeries k) + (completedChartAffineArc hm I W.toCompleted i) + have hprojective : ∀ j, + MvPolynomial.eval + (projectiveChartPoint W.toCompleted.chart qLaurent) + (W.toCompleted.equations j) = 0 := by + intro j + rw [projectiveChartPoint_completedChartAffineArc] + exact W.toCompleted.equations_vanish j + have hlaurent : + MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) qLaurent f = 0 := by + have hmem := W.chart_ideal_containment + (Ideal.mem_map_of_mem + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) hf) + have heval := eval_eq_zero_of_mem_chartDehomogenizedEquationIdeal + W.toCompleted.chart W.toCompleted.equations qLaurent hprojective + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m) f) hmem + simpa [eval_scalarPolynomialMap] using heval + apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) + have hmap := MvPolynomial.eval₂_comp_left + (algebraMap (PowerSeries k) (LaurentSeries k)) + (algebraMap k (PowerSeries k)) + (completedChartAffineArc hm I W.toCompleted) f + have hcoeff : + (algebraMap (PowerSeries k) (LaurentSeries k)).comp + (algebraMap k (PowerSeries k)) = + algebraMap k (LaurentSeries k) := by + ext a + simp [PowerSeries.algebraMap_eq, PowerSeries.coe_C, + LaurentSeries.algebraMap_apply] + rw [hcoeff] at hmap + have hpoint : + (algebraMap (PowerSeries k) (LaurentSeries k)) ∘ + completedChartAffineArc hm I W.toCompleted = qLaurent := by + rfl + rw [hpoint, hlaurent] at hmap + simpa using hmap + + +end + +end Stafford38.Geometry.ChartArcAnnihilation diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CoisotropicTranslation.lean b/LeanPool/Stafford38/Stafford38/Geometry/CoisotropicTranslation.lean new file mode 100644 index 0000000000..c335bf62ae --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CoisotropicTranslation.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial + +/-! +# Poisson closure and vertical translation + +This file proves a polynomial statement used by the coisotropic part of the +Stafford argument. If a Poisson ideal vanishes at a point of the zero section +and contains a polynomial in the base variables, then it also vanishes after +the fibre coordinate is translated by any scalar multiple of the differential +of that base polynomial at the point. + +Only polynomial rings, ideals, partial derivatives, and evaluation maps occur +here. In particular, no variety, characteristic support, conormal bundle, or +geometric integration theorem is represented by these declarations. +-/ + +namespace Stafford38.Geometry.CoisotropicTranslation + +open Stafford38.Characteristic + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- Embed a polynomial in the base coordinates into the phase-space ring. -/ +def baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n := + MvPolynomial.rename Sum.inl + +/-- Evaluate the differential of a base polynomial at a base point. -/ +def differentialAt (y : Fin n → k) (f : MvPolynomial (Fin n) k) (i : Fin n) : k := + MvPolynomial.eval y (MvPolynomial.pderiv i f) + +/-- The zero-section point over `y`. -/ +def zeroSectionPoint (y : Fin n → k) : PhaseVar n → k + | Sum.inl i => y i + | Sum.inr _ => 0 + +/-- The point obtained from `(y, 0)` by translating the fibre by `t df_y`. -/ +def differentialTranslatePoint + (y : Fin n → k) (f : MvPolynomial (Fin n) k) (t : k) : PhaseVar n → k + | Sum.inl i => y i + | Sum.inr i => t * differentialAt y f i + +/-- The polynomial line `t ↦ g(y, t v)` in the fibre over `y`. -/ +def fibreLinePolynomial + (y v : Fin n → k) (g : SymbolRing k n) : Polynomial k := + MvPolynomial.aeval (Sum.elim (fun i => Polynomial.C (y i)) + (fun i => Polynomial.C (v i) * Polynomial.X)) g + +/-- Directional derivative in the fibre variables. -/ +def verticalDeriv (v : Fin n → k) (g : SymbolRing k n) : SymbolRing k n := + ∑ i, MvPolynomial.C (v i) * MvPolynomial.pderiv (Sum.inr i) g + +@[simp] theorem verticalDeriv_C (v : Fin n → k) (a : k) : + verticalDeriv v (MvPolynomial.C a) = 0 := by + simp [verticalDeriv] + +theorem verticalDeriv_add (v : Fin n → k) (g h : SymbolRing k n) : + verticalDeriv v (g + h) = verticalDeriv v g + verticalDeriv v h := by + simp [verticalDeriv, mul_add, Finset.sum_add_distrib] + +theorem verticalDeriv_mul (v : Fin n → k) (g h : SymbolRing k n) : + verticalDeriv v (g * h) = verticalDeriv v g * h + g * verticalDeriv v h := by + simp only [verticalDeriv, MvPolynomial.pderiv_mul, mul_add, + Finset.sum_add_distrib] + apply congrArg₂ (· + ·) + · rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro i hi + ac_rfl + · rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + ac_rfl + +@[simp] theorem verticalDeriv_X_base (v : Fin n → k) (i : Fin n) : + verticalDeriv v (MvPolynomial.X (Sum.inl i)) = 0 := by + simp [verticalDeriv] + +@[simp] theorem verticalDeriv_X_fibre (v : Fin n → k) (i : Fin n) : + verticalDeriv v (MvPolynomial.X (Sum.inr i)) = MvPolynomial.C (v i) := by + classical + simp [verticalDeriv, Pi.single_apply] + +@[simp] theorem fibreLinePolynomial_C + (y v : Fin n → k) (a : k) : + fibreLinePolynomial y v (MvPolynomial.C a) = Polynomial.C a := by + simp [fibreLinePolynomial] + +@[simp] theorem fibreLinePolynomial_zero (y v : Fin n → k) : + fibreLinePolynomial y v 0 = 0 := by + simp [fibreLinePolynomial] + +@[simp] theorem fibreLinePolynomial_add + (y v : Fin n → k) (g h : SymbolRing k n) : + fibreLinePolynomial y v (g + h) = + fibreLinePolynomial y v g + fibreLinePolynomial y v h := by + simp [fibreLinePolynomial] + +@[simp] theorem fibreLinePolynomial_mul + (y v : Fin n → k) (g h : SymbolRing k n) : + fibreLinePolynomial y v (g * h) = + fibreLinePolynomial y v g * fibreLinePolynomial y v h := by + simp [fibreLinePolynomial] + +theorem fibreLinePolynomial_sum {ι : Type*} [Fintype ι] + (y v : Fin n → k) (g : ι → SymbolRing k n) : + fibreLinePolynomial y v (∑ i, g i) = ∑ i, fibreLinePolynomial y v (g i) := by + simp [fibreLinePolynomial] + +@[simp] theorem fibreLinePolynomial_X_base + (y v : Fin n → k) (i : Fin n) : + fibreLinePolynomial y v (MvPolynomial.X (Sum.inl i)) = Polynomial.C (y i) := by + simp [fibreLinePolynomial] + +@[simp] theorem fibreLinePolynomial_X_fibre + (y v : Fin n → k) (i : Fin n) : + fibreLinePolynomial y v (MvPolynomial.X (Sum.inr i)) = + Polynomial.C (v i) * Polynomial.X := by + simp [fibreLinePolynomial] + +theorem derivative_fibreLinePolynomial + (y v : Fin n → k) (g : SymbolRing k n) : + Polynomial.derivative (fibreLinePolynomial y v g) = + fibreLinePolynomial y v (verticalDeriv v g) := by + induction g using MvPolynomial.induction_on with + | C a => simp [verticalDeriv] + | add p q hp hq => + simp only [fibreLinePolynomial_add, Polynomial.derivative_add, hp, hq] + rw [verticalDeriv_add, fibreLinePolynomial_add] + | mul_X p i hp => + rcases i with i | i + · simp only [fibreLinePolynomial_mul, fibreLinePolynomial_X_base, Polynomial.derivative_mul, + Polynomial.derivative_C, zero_mul, add_zero, hp] + simp [verticalDeriv_mul] + · simp only [fibreLinePolynomial_mul, fibreLinePolynomial_X_fibre, Polynomial.derivative_mul, + Polynomial.derivative_C, Polynomial.derivative_X, zero_mul, zero_add, mul_one, hp] + simp [verticalDeriv_mul] + +theorem eval_fibreLinePolynomial (y v : Fin n → k) + (g : SymbolRing k n) (t : k) : + Polynomial.eval t (fibreLinePolynomial y v g) = + MvPolynomial.eval (Sum.elim y (fun i => t * v i)) g := by + change Polynomial.aeval t + (MvPolynomial.aeval (Sum.elim (fun i => Polynomial.C (y i)) + (fun i => Polynomial.C (v i) * Polynomial.X)) g) = _ + rw [MvPolynomial.comp_aeval_apply] + change MvPolynomial.aeval _ g = MvPolynomial.aeval _ g + apply DFunLike.congr_fun + apply MvPolynomial.algHom_ext + intro i + rcases i with i | i + · rw [MvPolynomial.aeval_X, MvPolynomial.aeval_X] + simp + · rw [MvPolynomial.aeval_X, MvPolynomial.aeval_X] + simp only [Sum.elim_inr, map_mul, Polynomial.aeval_C, Polynomial.aeval_X] + simp + ring + +theorem eval_zero_fibreLinePolynomial (y v : Fin n → k) + (g : SymbolRing k n) : + Polynomial.eval 0 (fibreLinePolynomial y v g) = + MvPolynomial.eval (zeroSectionPoint y) g := by + rw [eval_fibreLinePolynomial] + apply MvPolynomial.eval₂_congr + intro i c hi hc + rcases i with i | i <;> simp [zeroSectionPoint] + +theorem pderiv_baseLift_base (f : MvPolynomial (Fin n) k) (i : Fin n) : + MvPolynomial.pderiv (Sum.inl i) (baseLift f) = + baseLift (MvPolynomial.pderiv i f) := by + exact MvPolynomial.pderiv_rename Sum.inl_injective i f + +theorem pderiv_baseLift_fibre (f : MvPolynomial (Fin n) k) (i : Fin n) : + MvPolynomial.pderiv (Sum.inr i) (baseLift f) = 0 := by + apply MvPolynomial.pderiv_eq_zero_of_notMem_vars + intro hi + rcases MvPolynomial.mem_vars_rename Sum.inl f hi with ⟨j, hj, hji⟩ + exact Sum.inl_ne_inr hji + +theorem fibreLinePolynomial_baseLift + (y v : Fin n → k) (f : MvPolynomial (Fin n) k) : + fibreLinePolynomial y v (baseLift f) = Polynomial.C (MvPolynomial.eval y f) := by + induction f using MvPolynomial.induction_on with + | C a => simp [baseLift, fibreLinePolynomial, differentialAt] + | add p q hp hq => simp only [map_add, fibreLinePolynomial_add, hp, hq, + MvPolynomial.eval_add, map_add] + | mul_X p j hp => + rw [map_mul, fibreLinePolynomial_mul, hp, MvPolynomial.eval_mul, + MvPolynomial.eval_X, map_mul] + simp [baseLift] + +theorem fibreLinePolynomial_baseLift_pderiv + (y v : Fin n → k) (f : MvPolynomial (Fin n) k) (i : Fin n) : + fibreLinePolynomial y v + (MvPolynomial.pderiv (Sum.inl i) (baseLift f)) = + Polynomial.C (differentialAt y f i) := by + rw [pderiv_baseLift_base, fibreLinePolynomial_baseLift] + rfl + +theorem fibreLinePolynomial_poissonBracket_baseLift + (y : Fin n → k) (f : MvPolynomial (Fin n) k) (g : SymbolRing k n) : + fibreLinePolynomial y (differentialAt y f) (poissonBracket (baseLift f) g) = + fibreLinePolynomial y (differentialAt y f) + (verticalDeriv (differentialAt y f) g) := by + simp only [poissonBracket, pderiv_baseLift_base, pderiv_baseLift_fibre, zero_mul, + sub_zero, verticalDeriv, fibreLinePolynomial_sum] + apply Finset.sum_congr rfl + intro i hi + simp [fibreLinePolynomial_mul, fibreLinePolynomial_baseLift, differentialAt] + +/-! ## Iterated Hamiltonian differentiation -/ + +/-- Iteration of bracketing on the left by one base equation. -/ +def hamiltonIter (f : MvPolynomial (Fin n) k) : ℕ → SymbolRing k n → SymbolRing k n + | 0, g => g + | m + 1, g => poissonBracket (baseLift f) (hamiltonIter f m g) + +theorem iterate_derivative_fibreLinePolynomial + (y : Fin n → k) (f : MvPolynomial (Fin n) k) + (g : SymbolRing k n) (m : ℕ) : + (Polynomial.derivative^[m]) + (fibreLinePolynomial y (differentialAt y f) g) = + fibreLinePolynomial y (differentialAt y f) (hamiltonIter f m g) := by + induction m with + | zero => rfl + | succ m hm => + rw [Function.iterate_succ_apply', hm, derivative_fibreLinePolynomial, + ← fibreLinePolynomial_poissonBracket_baseLift] + rfl + +theorem hamiltonIter_mem + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) : + ∀ m, hamiltonIter f m g ∈ J := by + intro m + induction m with + | zero => exact hg + | succ m hm => exact hJ (baseLift f) hf (hamiltonIter f m g) + +theorem polynomial_eq_zero_of_eval_iterate_derivative_zero + [CharZero k] + (q : Polynomial k) + (h : ∀ m, Polynomial.eval 0 ((Polynomial.derivative^[m]) q) = 0) : + q = 0 := by + ext m + have hm0 : ((Polynomial.derivative^[m]) q).coeff 0 = 0 := by + rw [Polynomial.coeff_zero_eq_eval_zero] + exact h m + have hm : (Nat.factorial m : k) * q.coeff m = 0 := by + simpa only [Polynomial.coeff_iterate_derivative, zero_add, + Nat.descFactorial_self, nsmul_eq_mul] using hm0 + have hc : q.coeff m = 0 := + (mul_eq_zero.mp hm).resolve_left (by exact_mod_cast Nat.factorial_ne_zero m) + simpa using hc + +theorem fibreLinePolynomial_eq_zero_of_poisson + [CharZero k] + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) : + fibreLinePolynomial y (differentialAt y f) g = 0 := by + apply polynomial_eq_zero_of_eval_iterate_derivative_zero + intro m + rw [iterate_derivative_fibreLinePolynomial, eval_zero_fibreLinePolynomial] + exact hzero _ (hamiltonIter_mem J hJ f hf g hg m) + +/-! ## The exact translation statement -/ + +/-- +A zero-section common zero of a Poisson ideal remains a common zero after +vertical translation by `t df_y`, for every scalar `t`, whenever the base +polynomial `f` belongs to the ideal. + +The radical hypothesis customary in the geometric application is unnecessary +for this polynomial implication; see the wrapper below. +-/ +theorem zeroSection_stable_under_differential_translation + [CharZero k] + (J : Ideal (SymbolRing k n)) (hJ : IsPoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) (t : k) : + MvPolynomial.eval (differentialTranslatePoint y f t) g = 0 := by + have heval : + MvPolynomial.eval (differentialTranslatePoint y f t) g = + MvPolynomial.eval (Sum.elim y (fun i => t * differentialAt y f i)) g := by + apply MvPolynomial.eval₂_congr + intro i c hi hc + rcases i with i | i <;> rfl + rw [heval, ← eval_fibreLinePolynomial] + rw [fibreLinePolynomial_eq_zero_of_poisson J hJ y hzero f hf g hg] + exact Polynomial.eval_zero + +/-- The same statement with the radical hypothesis carried explicitly. -/ +theorem radicalPoisson_zeroSection_stable_under_differential_translation + [CharZero k] + (J : Ideal (SymbolRing k n)) (_hJrad : J.IsRadical) (hJ : IsPoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : MvPolynomial (Fin n) k) (hf : baseLift f ∈ J) + (g : SymbolRing k n) (hg : g ∈ J) (t : k) : + MvPolynomial.eval (differentialTranslatePoint y f t) g = 0 := + zeroSection_stable_under_differential_translation J hJ y hzero f hf g hg t + + +end + +end Stafford38.Geometry.CoisotropicTranslation diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRCoefficientSection.lean b/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRCoefficientSection.lean new file mode 100644 index 0000000000..bf3e837c61 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRCoefficientSection.lean @@ -0,0 +1,330 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FiniteSeparableDVRChartFoundation +import LeanPool.Stafford38.Stafford38.Geometry.RelativeCoefficientDVRPlace +import Mathlib.RingTheory.AdicCompletion.Algebra +import Mathlib.RingTheory.Ideal.Quotient.Nilpotent + +/-! +# A residue-field section in the adic completion of the retained DVR + +Let `V` be a commutative local `E`-algebra and let `K` be its residue field. +If `K/E` is separable, formal etaleness gives a unique coefficient section in +every positive quotient `V / m^(n+1)`. Uniqueness makes those sections +compatible with the quotient transition maps. This file assembles the +compatible family in Mathlib's `m`-adic completion and proves that the +level-one residue map retracts it. + +The retained DVR produced by `RelativeCoefficientDVRPlace` satisfies the +separability hypothesis in characteristic zero, so the construction applies +to it directly. No equivalence with a power-series ring is asserted. +-/ + +namespace Stafford38.Geometry.CompletedDVRCoefficientSection + +open IsLocalRing +open Stafford38.Geometry.FiniteSeparableDVRChartFoundation +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RetainedDVR +open Stafford38.Geometry.AsymptoticDivisorExistence + +noncomputable section + + +universe u + +section LocalAlgebra + +variable (E V : Type u) +variable [Field E] [CommRing V] [IsLocalRing V] [Algebra E V] + +private abbrev K := ResidueField V +private abbrev m : Ideal V := maximalIdeal V + +/-- The positive `n`-th nilpotent quotient of the local ring. -/ +abbrev AdicJet (n : ℕ) := V ⧸ ((m V) ^ (n + 1)) + +/-- Reduction of a positive adic jet to the residue field. -/ +def adicJetResidue (n : ℕ) : AdicJet V n →ₐ[E] K V := + Ideal.Quotient.liftₐ ((m V) ^ (n + 1)) + (IsScalarTower.toAlgHom E V (K V)) (by + intro x hx + change residue V x = 0 + rw [residue_eq_zero_iff] + exact Ideal.pow_le_self (Nat.succ_ne_zero n) hx) + +/-- Reduction from every positive adic jet is surjective. -/ +theorem adicJetResidue_surjective (n : ℕ) : + Function.Surjective (adicJetResidue E V n) := by + intro z + obtain ⟨x, rfl⟩ := residue_surjective (R := V) z + exact ⟨Ideal.Quotient.mk ((m V) ^ (n + 1)) x, rfl⟩ + +/-- The kernel of positive-jet reduction is nilpotent. -/ +theorem adicJetResidue_kernel_isNilpotent (n : ℕ) : + IsNilpotent (RingHom.ker (adicJetResidue E V n).toRingHom) := by + have hkerLift : + RingHom.ker (adicJetResidue E V n).toRingHom = + (RingHom.ker (IsScalarTower.toAlgHom E V (K V)).toRingHom).map + (Ideal.Quotient.mk ((m V) ^ (n + 1))) := by + exact Ideal.ker_quotient_lift _ _ + rw [hkerLift] + have hker : + RingHom.ker (IsScalarTower.toAlgHom E V (K V)).toRingHom = m V := by + change RingHom.ker (algebraMap V (K V)) = m V + rw [ResidueField.algebraMap_eq, ker_residue] + rw [hker] + refine ⟨n + 1, ?_⟩ + rw [← Ideal.map_pow, Ideal.map_quotient_self] + rfl + +/-- The unique coefficient section in the positive `n`-th adic jet. -/ +def adicJetCoefficientSection + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) : + K V →ₐ[E] AdicJet V n := + finiteSeparableSection E (K V) (AdicJet V n) hsep + (adicJetResidue E V n) (adicJetResidue_surjective E V n) + (adicJetResidue_kernel_isNilpotent E V n) + +/-- Each finite-level coefficient map is a section of reduction. -/ +@[simp] +theorem adicJetResidue_comp_adicJetCoefficientSection + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) : + (adicJetResidue E V n).comp (adicJetCoefficientSection E V hsep n) = + AlgHom.id E (K V) := + residue_comp_finiteSeparableSection E (K V) (AdicJet V n) hsep + (adicJetResidue E V n) (adicJetResidue_surjective E V n) + (adicJetResidue_kernel_isNilpotent E V n) + +/-- The transition map between two positive adic jets. -/ +def adicJetTransition {a b : ℕ} (hab : a ≤ b) : + AdicJet V b →ₐ[E] AdicJet V a := + Ideal.quotientMapₐ ((m V) ^ (a + 1)) (AlgHom.id E V) (by + simpa using Ideal.pow_le_pow_right (Nat.add_le_add_right hab 1)) + +/-- Reduction commutes with every positive-jet transition. -/ +theorem adicJetResidue_comp_transition {a b : ℕ} (hab : a ≤ b) : + (adicJetResidue E V a).comp (adicJetTransition E V hab) = + adicJetResidue E V b := by + ext x + obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x + rfl + +/-- Uniqueness forces the positive finite-level sections to be compatible. -/ +theorem adicJetCoefficientSection_compatible + (hsep : Algebra.IsSeparable E (K V)) {a b : ℕ} (hab : a ≤ b) : + (adicJetTransition E V hab).comp + (adicJetCoefficientSection E V hsep b) = + adicJetCoefficientSection E V hsep a := by + exact finiteSeparableSection_naturality E (K V) + (AdicJet V a) (AdicJet V b) hsep + (adicJetResidue E V a) (adicJetResidue_surjective E V a) + (adicJetResidue_kernel_isNilpotent E V a) + (adicJetResidue E V b) (adicJetResidue_surjective E V b) + (adicJetResidue_kernel_isNilpotent E V b) + (adicJetTransition E V hab) (adicJetResidue_comp_transition E V hab) + +/-- Convert the usual quotient by `m^n` to the coordinate quotient used in +the definition of `AdicCompletion`. -/ +private def exactQuotientToCompletionCoordinate (n : ℕ) : + (V ⧸ ((m V) ^ n)) ≃ₐ[E] + V ⧸ ((m V) ^ n • ⊤ : Ideal V) := by + have h : ((m V) ^ n • ⊤ : Ideal V) = (m V) ^ n := by + ext x + simp + exact (Ideal.quotientEquivAlgOfEq V h).symm.restrictScalars E + +/-- The zeroth completion coordinate is the zero quotient, so it has a unique +`E`-algebra map from the residue field. -/ +private def zeroCompletionCoordinateSection : + K V →ₐ[E] V ⧸ ((m V) ^ 0 • ⊤ : Ideal V) := by + have htop : ((m V) ^ 0 • ⊤ : Ideal V) = ⊤ := by simp + letI : Subsingleton (V ⧸ ((m V) ^ 0 • ⊤ : Ideal V)) := by + rw [htop] + infer_instance + exact { + toFun := fun _ ↦ 0 + map_one' := Subsingleton.elim _ _ + map_mul' := fun _ _ ↦ Subsingleton.elim _ _ + map_zero' := rfl + map_add' := fun _ _ ↦ Subsingleton.elim _ _ + commutes' := fun _ ↦ Subsingleton.elim _ _ } + +/-- The coefficient section in every coordinate of Mathlib's adic inverse +limit. Coordinate zero is trivial; coordinate `n+1` is the formally etale +section in `V / m^(n+1)`. -/ +def completionCoordinateSection + (hsep : Algebra.IsSeparable E (K V)) : + ∀ n : ℕ, K V →ₐ[E] V ⧸ ((m V) ^ n • ⊤ : Ideal V) + | 0 => zeroCompletionCoordinateSection E V + | n + 1 => + (exactQuotientToCompletionCoordinate E V (n + 1)).toAlgHom.comp + (adicJetCoefficientSection E V hsep n) + +/-- Transition on exact power quotients agrees with transition on the raw +coordinates occurring in `AdicCompletion`. -/ +private theorem transition_exactQuotientToCompletionCoordinate + {a b : ℕ} (hab : a ≤ b) (x : V ⧸ ((m V) ^ b)) : + AdicCompletion.transitionMap (m V) V hab + (exactQuotientToCompletionCoordinate E V b x) = + exactQuotientToCompletionCoordinate E V a + (Ideal.quotientMapₐ ((m V) ^ a) (AlgHom.id E V) + (by simpa using Ideal.pow_le_pow_right hab) x) := by + obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x + rfl + +/-- The completion-coordinate sections form a compatible inverse-limit +family. -/ +theorem completionCoordinateSection_compatible + (hsep : Algebra.IsSeparable E (K V)) {a b : ℕ} (hab : a ≤ b) + (x : K V) : + AdicCompletion.transitionMap (m V) V hab + (completionCoordinateSection E V hsep b x) = + completionCoordinateSection E V hsep a x := by + cases a with + | zero => + have htop : ((m V) ^ 0 • ⊤ : Ideal V) = ⊤ := by simp + letI : Subsingleton (V ⧸ ((m V) ^ 0 • ⊤ : Ideal V)) := by + rw [htop] + infer_instance + exact Subsingleton.elim _ _ + | succ a => + cases b with + | zero => omega + | succ b => + have hab' : a ≤ b := Nat.succ_le_succ_iff.mp hab + change AdicCompletion.transitionMap (m V) V hab + (exactQuotientToCompletionCoordinate E V (b + 1) + (adicJetCoefficientSection E V hsep b x)) = + exactQuotientToCompletionCoordinate E V (a + 1) + (adicJetCoefficientSection E V hsep a x) + rw [transition_exactQuotientToCompletionCoordinate E V hab] + change exactQuotientToCompletionCoordinate E V (a + 1) + (adicJetTransition E V hab' + (adicJetCoefficientSection E V hsep b x)) = + exactQuotientToCompletionCoordinate E V (a + 1) + (adicJetCoefficientSection E V hsep a x) + exact congrArg (exactQuotientToCompletionCoordinate E V (a + 1)) + (DFunLike.congr_fun + (adicJetCoefficientSection_compatible E V hsep hab') x) + +/-- The compatible finite-level sections assemble to an actual +`E`-algebra coefficient section in the adic completion. -/ +def completedCoefficientSection + (hsep : Algebra.IsSeparable E (K V)) : + K V →ₐ[E] AdicCompletion (m V) V where + toFun x := + ⟨fun n ↦ completionCoordinateSection E V hsep n x, + fun hab ↦ completionCoordinateSection_compatible E V hsep hab x⟩ + map_one' := AdicCompletion.ext fun n ↦ + (completionCoordinateSection E V hsep n).map_one + map_mul' x y := AdicCompletion.ext fun n ↦ + (completionCoordinateSection E V hsep n).map_mul x y + map_zero' := AdicCompletion.ext fun n ↦ + (completionCoordinateSection E V hsep n).map_zero + map_add' x y := AdicCompletion.ext fun n ↦ + (completionCoordinateSection E V hsep n).map_add x y + commutes' e := AdicCompletion.ext fun n ↦ + (completionCoordinateSection E V hsep n).commutes e + +/-- Evaluation of the completed section at every positive level recovers the +finite-level section constructed by formal etaleness. -/ +theorem eval_completedCoefficientSection + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) : + ((AdicCompletion.evalₐ (m V) (n + 1)).restrictScalars E).comp + (completedCoefficientSection E V hsep) = + adicJetCoefficientSection E V hsep n := by + ext x + simp only [AlgHom.comp_apply, AlgHom.restrictScalars_apply, + completedCoefficientSection, AdicCompletion.evalₐ, AdicCompletion.eval_apply, + completionCoordinateSection, exactQuotientToCompletionCoordinate] + have h : ((m V) ^ (n + 1) • ⊤ : Ideal V) = (m V) ^ (n + 1) := by + ext y + simp + change (Ideal.quotientEquivAlgOfEq V h) + ((Ideal.quotientEquivAlgOfEq V h).symm + (adicJetCoefficientSection E V hsep n x)) = + adicJetCoefficientSection E V hsep n x + exact (Ideal.quotientEquivAlgOfEq V h).apply_symm_apply _ + +/-- Residue specialization of the completion is evaluation modulo `m`, +followed by the ordinary residue map. -/ +def completedResidue : + AdicCompletion (m V) V →ₐ[E] K V := + (adicJetResidue E V 0).comp + ((AdicCompletion.evalₐ (m V) 1).restrictScalars E) + +/-- The adic-completion coefficient map is an actual section of residue. -/ +@[simp] +theorem completedResidue_comp_completedCoefficientSection + (hsep : Algebra.IsSeparable E (K V)) : + (completedResidue E V).comp (completedCoefficientSection E V hsep) = + AlgHom.id E (K V) := by + ext x + change adicJetResidue E V 0 + (AdicCompletion.evalₐ (m V) 1 + (completedCoefficientSection E V hsep x)) = x + have heval := + DFunLike.congr_fun (eval_completedCoefficientSection E V hsep 0) x + change AdicCompletion.evalₐ (m V) 1 + (completedCoefficientSection E V hsep x) = + adicJetCoefficientSection E V hsep 0 x at heval + rw [heval] + exact DFunLike.congr_fun + (adicJetResidue_comp_adicJetCoefficientSection E V hsep 0) x + +end LocalAlgebra + +section RetainedDVR + +private abbrev SourceDVR (E : Type u) [Field E] := + CoordinateZeroLocalRing E + +/-- The actual residue-field coefficient section in the maximal-ideal adic +completion of a retained DVR place. -/ +def retainedCompletedCoefficientSection + (E : Type u) [Field E] [CharZero E] + {L : Type u} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + ResidueField D.valuation.toSubring →ₐ[E] + AdicCompletion (maximalIdeal D.valuation.toSubring) + D.valuation.toSubring := by + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + exact completedCoefficientSection E D.valuation.toSubring + (relativeResidue_isSeparable E D) + +/-- The retained completed coefficient section is split by completed residue +specialization. -/ +theorem retainedCompletedCoefficientSection_isSection + (E : Type u) [Field E] [CharZero E] + {L : Type u} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + (completedResidue E D.valuation.toSubring).comp + (retainedCompletedCoefficientSection E D) = + AlgHom.id E (ResidueField D.valuation.toSubring) := by + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + exact completedResidue_comp_completedCoefficientSection E + D.valuation.toSubring (relativeResidue_isSeparable E D) + +end RetainedDVR + + +end + +end Stafford38.Geometry.CompletedDVRCoefficientSection diff --git a/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRPowerSeriesEquiv.lean b/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRPowerSeriesEquiv.lean new file mode 100644 index 0000000000..4a7cd15bfc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/CompletedDVRPowerSeriesEquiv.lean @@ -0,0 +1,670 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRCoefficientSection +import Mathlib.RingTheory.PowerSeries.Trunc +import Mathlib.RingTheory.DiscreteValuationRing.Basic + +/-! +# A chosen-coordinate power-series map to a completed DVR + +For a discrete valuation ring `V`, choose an actual uniformizer `pi`, not an +arbitrary nonzero nonunit. A residue-field section in the maximal-ideal adic +completion then gives a map depending on those choices + +`(ResidueField V)[[X]] -> AdicCompletion (maximalIdeal V) V` + +by evaluating the `n`-th truncation modulo the `n`-th power of the maximal +ideal. This file constructs that map directly from the inverse-limit +coordinates and proves its coefficient and uniformizer formulas. + +No Cohen structure theorem is invoked. In particular, an equivalence is +constructed only from a separately proved surjectivity statement. +-/ + +namespace Stafford38.Geometry.CompletedDVRPowerSeries + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CompletedDVRCoefficientSection +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RetainedDVR + +noncomputable section + + +universe u + +section NilpotentEvaluation + +variable {K S : Type u} [CommRing K] [CommRing S] + +/-- Polynomials agreeing below degree `n` have the same value at an element +whose `n`-th power vanishes. -/ +private theorem eval₂_eq_of_coeff_eq_of_pow_eq_zero + (c : K →+* S) (x : S) (n : ℕ) (hx : x ^ n = 0) + {p q : Polynomial K} + (hcoeff : ∀ d < n, p.coeff d = q.coeff d) : + Polynomial.eval₂ c x p = Polynomial.eval₂ c x q := by + have hdvd : (Polynomial.X : Polynomial K) ^ n ∣ p - q := by + rw [Polynomial.X_pow_dvd_iff] + intro d hd + simp [hcoeff d hd] + obtain ⟨r, hr⟩ := hdvd + have hzero : Polynomial.eval₂ c x (p - q) = 0 := by + rw [hr, Polynomial.eval₂_mul, Polynomial.eval₂_pow, + Polynomial.eval₂_X, hx, zero_mul] + rw [Polynomial.eval₂_sub, sub_eq_zero] at hzero + exact hzero + +/-- Evaluation of a power series at an `n`-nilpotent element, using its +degree-`< n` truncation. -/ +def nilpotentPowerSeriesEval + (c : K →+* S) (x : S) (n : ℕ) (hx : x ^ n = 0) : + PowerSeries K →+* S where + toFun f := Polynomial.eval₂ c x (PowerSeries.trunc n f) + map_zero' := by simp + map_add' f g := by simp + map_one' := by + cases n with + | zero => + have hsub : Subsingleton S := by + apply subsingleton_iff_zero_eq_one.mp + simpa using hx.symm + exact Subsingleton.elim _ _ + | succ n => simp + map_mul' f g := by + rw [← Polynomial.eval₂_mul] + apply eval₂_eq_of_coeff_eq_of_pow_eq_zero c x n hx + intro d hd + rw [PowerSeries.coeff_trunc, if_pos hd] + calc + (PowerSeries.coeff d) (f * g) = + (PowerSeries.coeff d) + ((PowerSeries.trunc n f : PowerSeries K) * + (PowerSeries.trunc n g : PowerSeries K)) := + PowerSeries.coeff_mul_eq_coeff_trunc_mul_trunc f g hd + _ = (PowerSeries.trunc n f * PowerSeries.trunc n g).coeff d := by + rw [← Polynomial.coe_mul] + exact Polynomial.coeff_coe + (PowerSeries.trunc n f * PowerSeries.trunc n g) d + +@[simp] +theorem nilpotentPowerSeriesEval_C + (c : K →+* S) (x : S) (n : ℕ) (hx : x ^ n = 0) (a : K) : + nilpotentPowerSeriesEval c x n hx (PowerSeries.C a) = c a := by + cases n with + | zero => + have hone : (1 : S) = 0 := by simpa using hx + have hsub : Subsingleton S := + subsingleton_iff_zero_eq_one.mp hone.symm + exact Subsingleton.elim _ _ + | succ n => simp [nilpotentPowerSeriesEval] + +@[simp] +theorem nilpotentPowerSeriesEval_X + (c : K →+* S) (x : S) (n : ℕ) (hx : x ^ n = 0) : + nilpotentPowerSeriesEval c x n hx PowerSeries.X = x := by + cases n with + | zero => + have hone : (1 : S) = 0 := by simpa using hx + have hsub : Subsingleton S := + subsingleton_iff_zero_eq_one.mp hone.symm + exact Subsingleton.elim _ _ + | succ n => + cases n with + | zero => + have hx0 : x = 0 := by simpa using hx + simp [nilpotentPowerSeriesEval, PowerSeries.trunc_one_X, hx0] + | succ n => + simp [nilpotentPowerSeriesEval, PowerSeries.trunc_X_of] + +/-- Truncated evaluation is independent of a larger truncation once the +smaller nilpotence exponent has been reached. -/ +private theorem nilpotentPowerSeriesEval_truncation_independent + (c : K →+* S) (x : S) {m n : ℕ} (hmn : m ≤ n) + (hx : x ^ m = 0) (f : PowerSeries K) : + Polynomial.eval₂ c x (PowerSeries.trunc n f) = + Polynomial.eval₂ c x (PowerSeries.trunc m f) := by + apply eval₂_eq_of_coeff_eq_of_pow_eq_zero c x m hx + intro d hd + rw [PowerSeries.coeff_trunc, if_pos (lt_of_lt_of_le hd hmn), + PowerSeries.coeff_trunc, if_pos hd] + +end NilpotentEvaluation + +section CompleteDVR + +variable (E V : Type u) +variable [Field E] [CommRing V] [IsDomain V] [IsLocalRing V] +variable [IsDiscreteValuationRing V] [Algebra E V] + +private abbrev K := ResidueField V +private abbrev m : Ideal V := maximalIdeal V + +/-- A fixed genuine uniformizer of the DVR. -/ +def chosenUniformizer : V := + Classical.choose (IsDiscreteValuationRing.exists_irreducible V) + +/-- The chosen element is irreducible. -/ +theorem chosenUniformizer_irreducible : + Irreducible (chosenUniformizer V) := + Classical.choose_spec (IsDiscreteValuationRing.exists_irreducible V) + +/-- Consequently the chosen element generates the maximal ideal. -/ +theorem maximalIdeal_eq_span_chosenUniformizer : + maximalIdeal V = Ideal.span {chosenUniformizer V} := + (chosenUniformizer_irreducible V).maximalIdeal_eq + +/-- The chosen uniformizer in the `n`-th raw completion coordinate. -/ +def uniformizerCoordinate (n : ℕ) : + V ⧸ ((m V) ^ n • ⊤ : Ideal V) := + Ideal.Quotient.mk _ (chosenUniformizer V) + +/-- Its `n`-th power vanishes in the `n`-th coordinate. -/ +theorem uniformizerCoordinate_pow_eq_zero (n : ℕ) : + uniformizerCoordinate V n ^ n = 0 := by + rw [uniformizerCoordinate, ← map_pow, Ideal.Quotient.eq_zero_iff_mem] + simpa using Ideal.pow_mem_pow + (show chosenUniformizer V ∈ m V by + change chosenUniformizer V ∈ maximalIdeal V + rw [maximalIdeal_eq_span_chosenUniformizer V] + exact Ideal.mem_span_singleton_self _) n + +/-- Evaluation of a power series in one coordinate of the completed DVR. -/ +def powerSeriesCoordinateMap + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) : + PowerSeries (K V) →+* V ⧸ ((m V) ^ n • ⊤ : Ideal V) := + nilpotentPowerSeriesEval + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) n + (uniformizerCoordinate_pow_eq_zero V n) + +/-- Coordinate maps commute with every inverse-limit transition. -/ +theorem powerSeriesCoordinateMap_compatible + (hsep : Algebra.IsSeparable E (K V)) {a b : ℕ} (hab : a ≤ b) + (f : PowerSeries (K V)) : + AdicCompletion.transitionMap (m V) V hab + (powerSeriesCoordinateMap E V hsep b f) = + powerSeriesCoordinateMap E V hsep a f := by + let T := (AdicCompletion.transitionMapₐ (m V) hab).toRingHom + change T (Polynomial.eval₂ + (completionCoordinateSection E V hsep b).toRingHom + (uniformizerCoordinate V b) (PowerSeries.trunc b f)) = + Polynomial.eval₂ + (completionCoordinateSection E V hsep a).toRingHom + (uniformizerCoordinate V a) (PowerSeries.trunc a f) + rw [Polynomial.hom_eval₂] + have hc : + T.comp (completionCoordinateSection E V hsep b).toRingHom = + (completionCoordinateSection E V hsep a).toRingHom := by + ext z + exact completionCoordinateSection_compatible E V hsep hab z + have hx : T (uniformizerCoordinate V b) = uniformizerCoordinate V a := by + rfl + rw [hc, hx] + exact nilpotentPowerSeriesEval_truncation_independent + (completionCoordinateSection E V hsep a).toRingHom + (uniformizerCoordinate V a) hab + (uniformizerCoordinate_pow_eq_zero V a) f + +/-- The actual chosen-coordinate power-series map to the maximal-ideal adic +completion. -/ +def completedDVRPowerSeriesMap + (hsep : Algebra.IsSeparable E (K V)) : + PowerSeries (K V) →+* AdicCompletion (m V) V where + toFun f := + ⟨fun n ↦ powerSeriesCoordinateMap E V hsep n f, + fun hab ↦ powerSeriesCoordinateMap_compatible E V hsep hab f⟩ + map_zero' := AdicCompletion.ext fun n ↦ + (powerSeriesCoordinateMap E V hsep n).map_zero + map_one' := AdicCompletion.ext fun n ↦ + (powerSeriesCoordinateMap E V hsep n).map_one + map_add' f g := AdicCompletion.ext fun n ↦ + (powerSeriesCoordinateMap E V hsep n).map_add f g + map_mul' f g := AdicCompletion.ext fun n ↦ + (powerSeriesCoordinateMap E V hsep n).map_mul f g + +/-- Evaluation of the completed map at coordinate `n` is its truncated +polynomial evaluation there. -/ +theorem eval_completedDVRPowerSeriesMap + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) + (f : PowerSeries (K V)) : + (completedDVRPowerSeriesMap E V hsep f).val n = + powerSeriesCoordinateMap E V hsep n f := + rfl + +/-- Constant series map to the completed residue-field section. -/ +@[simp] +theorem completedDVRPowerSeriesMap_C + (hsep : Algebra.IsSeparable E (K V)) (a : K V) : + completedDVRPowerSeriesMap E V hsep (PowerSeries.C a) = + completedCoefficientSection E V hsep a := by + apply AdicCompletion.ext + intro n + exact nilpotentPowerSeriesEval_C + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) n + (uniformizerCoordinate_pow_eq_zero V n) a + +/-- The series variable maps to the chosen uniformizer in every completion +coordinate. -/ +@[simp] +theorem completedDVRPowerSeriesMap_X + (hsep : Algebra.IsSeparable E (K V)) : + completedDVRPowerSeriesMap E V hsep PowerSeries.X = + ⟨fun n ↦ uniformizerCoordinate V n, + fun hab ↦ by rfl⟩ := by + apply AdicCompletion.ext + intro n + exact nilpotentPowerSeriesEval_X + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) n + (uniformizerCoordinate_pow_eq_zero V n) + +/-- A coefficient-section value cannot be killed by the matching power of +the uniformizer one level too early. -/ +private theorem coefficient_eq_zero_of_mul_uniformizer_pow_eq_zero + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) (a : K V) + (hzero : + completionCoordinateSection E V hsep (n + 1) a * + uniformizerCoordinate V (n + 1) ^ n = 0) : + a = 0 := by + obtain ⟨v, hv⟩ := Ideal.Quotient.mk_surjective + (completionCoordinateSection E V hsep (n + 1) a) + have hmem : v * chosenUniformizer V ^ n ∈ (m V) ^ (n + 1) := by + have hraw : + Ideal.Quotient.mk ((m V) ^ (n + 1) • ⊤ : Ideal V) + (v * chosenUniformizer V ^ n) = 0 := by + rw [map_mul, map_pow, hv] + change completionCoordinateSection E V hsep (n + 1) a * + uniformizerCoordinate V (n + 1) ^ n = 0 + exact hzero + rw [Ideal.Quotient.eq_zero_iff_mem] at hraw + simpa using hraw + have hpowspan : + (m V) ^ (n + 1) = + Ideal.span {chosenUniformizer V ^ (n + 1)} := by + change (maximalIdeal V) ^ (n + 1) = _ + rw [maximalIdeal_eq_span_chosenUniformizer V, + Ideal.span_singleton_pow] + rw [hpowspan, Ideal.mem_span_singleton'] at hmem + obtain ⟨b, hb⟩ := hmem + have hvfactor : v = b * chosenUniformizer V := by + apply mul_right_cancel₀ (pow_ne_zero n + (chosenUniformizer_irreducible V).ne_zero) + calc + v * chosenUniformizer V ^ n = + b * chosenUniformizer V ^ (n + 1) := hb.symm + _ = (b * chosenUniformizer V) * chosenUniformizer V ^ n := by + rw [pow_succ'] + ring + have hvmax : v ∈ maximalIdeal V := by + rw [maximalIdeal_eq_span_chosenUniformizer V, + Ideal.mem_span_singleton'] + exact ⟨b, hvfactor.symm⟩ + have hvres : residue V v = a := by + have hab : 1 ≤ n + 1 := Nat.succ_le_succ (Nat.zero_le n) + have hv1 := congrArg + (AdicCompletion.transitionMap (m V) V hab) hv + rw [AdicCompletion.transitionMap_ideal_mk, + completionCoordinateSection_compatible E V hsep hab a] at hv1 + let rawResidue : + (V ⧸ ((m V) ^ 1 • ⊤ : Ideal V)) →+* K V := + Ideal.Quotient.lift _ (residue V) (by + intro z hz + rw [residue_eq_zero_iff] + simpa using hz) + have hres := congrArg rawResidue hv1 + change residue V v = rawResidue + (completionCoordinateSection E V hsep 1 a) at hres + rw [hres] + have ha := DFunLike.congr_fun + (adicJetResidue_comp_adicJetCoefficientSection E V hsep 0) a + change adicJetResidue E V 0 + (adicJetCoefficientSection E V hsep 0 a) = a at ha + calc + rawResidue (completionCoordinateSection E V hsep 1 a) = + adicJetResidue E V 0 + (adicJetCoefficientSection E V hsep 0 a) := by + simp only [rawResidue, completionCoordinateSection, adicJetResidue, + AlgHom.comp_apply, RingHom.coe_mk, MonoidHom.coe_mk, OneHom.coe_mk] + generalize hz : adicJetCoefficientSection E V hsep 0 a = z + obtain ⟨w, rfl⟩ := Ideal.Quotient.mk_surjective z + rfl + _ = a := ha + have hvzero : residue V v = 0 := + (IsLocalRing.residue_eq_zero_iff v).mpr hvmax + rw [hvzero] at hvres + exact hvres.symm + +/-- If all earlier coefficients vanish, vanishing of coordinate `n+1` +forces the `n`-th coefficient to vanish. -/ +private theorem coeff_eq_zero_of_coordinate_eq_zero + (hsep : Algebra.IsSeparable E (K V)) (f : PowerSeries (K V)) (n : ℕ) + (hprev : ∀ i < n, PowerSeries.coeff i f = 0) + (hcoord : powerSeriesCoordinateMap E V hsep (n + 1) f = 0) : + PowerSeries.coeff n f = 0 := by + have hsum : + ∑ i ∈ Finset.range (n + 1), + completionCoordinateSection E V hsep (n + 1) + (PowerSeries.coeff i f) * + uniformizerCoordinate V (n + 1) ^ i = 0 := by + simpa [powerSeriesCoordinateMap, nilpotentPowerSeriesEval, + PowerSeries.eval₂_trunc_eq_sum_range] using hcoord + have hsingle : + completionCoordinateSection E V hsep (n + 1) + (PowerSeries.coeff n f) * + uniformizerCoordinate V (n + 1) ^ n = 0 := by + rw [Finset.sum_eq_single n] at hsum + · exact hsum + · intro i hi hin + rw [Finset.mem_range] at hi + have hil : i < n := Nat.lt_of_le_of_ne + (Nat.le_of_lt_succ hi) hin + rw [hprev i hil, map_zero, zero_mul] + · simp + exact coefficient_eq_zero_of_mul_uniformizer_pow_eq_zero + E V hsep n _ hsingle + +/-- The chosen-coordinate map is injective. The proof detects the first nonzero +coefficient in the quotient modulo the next uniformizer power. -/ +theorem completedDVRPowerSeriesMap_injective + (hsep : Algebra.IsSeparable E (K V)) : + Function.Injective (completedDVRPowerSeriesMap E V hsep) := by + intro f g hfg + rw [← sub_eq_zero] + apply PowerSeries.ext + intro n + have hmap : completedDVRPowerSeriesMap E V hsep (f - g) = 0 := by + rw [map_sub, hfg, sub_self] + have hcoeff : ∀ r : ℕ, + PowerSeries.coeff r (f - g) = 0 := by + intro r + induction r using Nat.strong_induction_on with + | h r ih => + apply coeff_eq_zero_of_coordinate_eq_zero E V hsep (f - g) r ih + have := congrArg (fun z ↦ z.val (r + 1)) hmap + change powerSeriesCoordinateMap E V hsep (r + 1) (f - g) = 0 at this + exact this + exact hcoeff n + +/-- The kernel of the transition from level `n + 1` to level `n` consists of +one residue-field coefficient times the `n`-th uniformizer power. -/ +private theorem exists_coefficient_mul_uniformizer_pow_eq + (hsep : Algebra.IsSeparable E (K V)) (n : ℕ) + (y : V ⧸ ((m V) ^ (n + 1) • ⊤ : Ideal V)) + (hy : AdicCompletion.transitionMap (m V) V (Nat.le_succ n) y = 0) : + ∃ a : K V, + y = completionCoordinateSection E V hsep (n + 1) a * + uniformizerCoordinate V (n + 1) ^ n := by + obtain ⟨v, rfl⟩ := Ideal.Quotient.mk_surjective y + have hvpow : v ∈ (m V) ^ n := by + rw [AdicCompletion.transitionMap_ideal_mk, + Ideal.Quotient.eq_zero_iff_mem] at hy + simpa using hy + have hpowspan : + (m V) ^ n = Ideal.span {chosenUniformizer V ^ n} := by + change (maximalIdeal V) ^ n = _ + rw [maximalIdeal_eq_span_chosenUniformizer V, + Ideal.span_singleton_pow] + rw [hpowspan, Ideal.mem_span_singleton'] at hvpow + obtain ⟨c, rfl⟩ := hvpow + let a : K V := residue V c + obtain ⟨s, hs⟩ := Ideal.Quotient.mk_surjective + (completionCoordinateSection E V hsep (n + 1) a) + have hsres : residue V s = a := by + have hlevel : 1 ≤ n + 1 := Nat.succ_le_succ (Nat.zero_le n) + have hs1 := congrArg + (AdicCompletion.transitionMap (m V) V hlevel) hs + rw [AdicCompletion.transitionMap_ideal_mk, + completionCoordinateSection_compatible E V hsep hlevel a] at hs1 + let rawResidue : + (V ⧸ ((m V) ^ 1 • ⊤ : Ideal V)) →+* K V := + Ideal.Quotient.lift _ (residue V) (by + intro z hz + rw [residue_eq_zero_iff] + simpa using hz) + have hres := congrArg rawResidue hs1 + change residue V s = rawResidue + (completionCoordinateSection E V hsep 1 a) at hres + rw [hres] + have ha := DFunLike.congr_fun + (adicJetResidue_comp_adicJetCoefficientSection E V hsep 0) a + change adicJetResidue E V 0 + (adicJetCoefficientSection E V hsep 0 a) = a at ha + calc + rawResidue (completionCoordinateSection E V hsep 1 a) = + adicJetResidue E V 0 + (adicJetCoefficientSection E V hsep 0 a) := by + simp only [rawResidue, completionCoordinateSection, adicJetResidue, + AlgHom.comp_apply, RingHom.coe_mk, MonoidHom.coe_mk, OneHom.coe_mk] + generalize hz : adicJetCoefficientSection E V hsep 0 a = z + obtain ⟨w, rfl⟩ := Ideal.Quotient.mk_surjective z + rfl + _ = a := ha + have hdiff : c - s ∈ m V := by + change c - s ∈ maximalIdeal V + rw [← residue_eq_zero_iff, map_sub, hsres] + exact sub_self a + refine ⟨a, ?_⟩ + rw [← hs, map_mul, map_pow] + apply Ideal.Quotient.eq.mpr + change c * chosenUniformizer V ^ n - + s * chosenUniformizer V ^ n ∈ (m V) ^ (n + 1) • ⊤ + have hpow : chosenUniformizer V ^ n ∈ (m V) ^ n := + Ideal.pow_mem_pow + (show chosenUniformizer V ∈ m V by + change chosenUniformizer V ∈ maximalIdeal V + rw [maximalIdeal_eq_span_chosenUniformizer V] + exact Ideal.mem_span_singleton_self _) n + have hmul := Ideal.mul_mem_mul hdiff hpow + simpa [sub_mul, pow_succ, mul_comm] using hmul + +/-- Successive approximants matching one more adic coordinate at each step. -/ +private noncomputable def powerSeriesApproximant + (hsep : Algebra.IsSeparable E (K V)) + (z : AdicCompletion (m V) V) : + (n : ℕ) → { f : PowerSeries (K V) // + powerSeriesCoordinateMap E V hsep n f = z.val n } + | 0 => by + have htop : ((m V) ^ 0 • ⊤ : Ideal V) = ⊤ := by simp + letI : Subsingleton (V ⧸ ((m V) ^ 0 • ⊤ : Ideal V)) := by + rw [htop] + infer_instance + exact ⟨0, Subsingleton.elim _ _⟩ + | n + 1 => by + let f := powerSeriesApproximant hsep z n + let y := z.val (n + 1) - powerSeriesCoordinateMap E V hsep (n + 1) f + have hy : + AdicCompletion.transitionMap (m V) V (Nat.le_succ n) y = 0 := by + change AdicCompletion.transitionMap (m V) V (Nat.le_succ n) + (z.val (n + 1) - powerSeriesCoordinateMap E V hsep (n + 1) f) = 0 + rw [map_sub, z.property (Nat.le_succ n), + powerSeriesCoordinateMap_compatible E V hsep (Nat.le_succ n) f, + f.property, sub_self] + let a := Classical.choose + (exists_coefficient_mul_uniformizer_pow_eq E V hsep n y hy) + have ha := Classical.choose_spec + (exists_coefficient_mul_uniformizer_pow_eq E V hsep n y hy) + refine ⟨f.1 + PowerSeries.C a * PowerSeries.X ^ n, ?_⟩ + change powerSeriesCoordinateMap E V hsep (n + 1) + (f.1 + PowerSeries.C a * PowerSeries.X ^ n) = z.val (n + 1) + rw [map_add, map_mul, map_pow] + have hC : powerSeriesCoordinateMap E V hsep (n + 1) + (PowerSeries.C a) = + completionCoordinateSection E V hsep (n + 1) a := + nilpotentPowerSeriesEval_C + (completionCoordinateSection E V hsep (n + 1)).toRingHom + (uniformizerCoordinate V (n + 1)) (n + 1) + (uniformizerCoordinate_pow_eq_zero V (n + 1)) a + have hX : powerSeriesCoordinateMap E V hsep (n + 1) PowerSeries.X = + uniformizerCoordinate V (n + 1) := + nilpotentPowerSeriesEval_X + (completionCoordinateSection E V hsep (n + 1)).toRingHom + (uniformizerCoordinate V (n + 1)) (n + 1) + (uniformizerCoordinate_pow_eq_zero V (n + 1)) + rw [hC, hX] + rw [← ha] + change powerSeriesCoordinateMap E V hsep (n + 1) f + + (z.val (n + 1) - powerSeriesCoordinateMap E V hsep (n + 1) f) = + z.val (n + 1) + abel + +/-- Passing to the next approximant does not change any earlier coefficient. -/ +private theorem powerSeriesApproximant_succ_coeff + (hsep : Algebra.IsSeparable E (K V)) + (z : AdicCompletion (m V) V) (n i : ℕ) (hi : i < n) : + PowerSeries.coeff i (powerSeriesApproximant E V hsep z (n + 1)).1 = + PowerSeries.coeff i (powerSeriesApproximant E V hsep z n).1 := by + change PowerSeries.coeff i + ((powerSeriesApproximant E V hsep z n).1 + + PowerSeries.C _ * PowerSeries.X ^ n) = _ + rw [map_add, PowerSeries.coeff_C_mul, PowerSeries.coeff_X_pow, + if_neg hi.ne, mul_zero, add_zero] + +/-- All coefficients below level `a` are stable in every later approximant. -/ +private theorem powerSeriesApproximant_coeff_stable + (hsep : Algebra.IsSeparable E (K V)) + (z : AdicCompletion (m V) V) {a b i : ℕ} (hab : a ≤ b) (hi : i < a) : + PowerSeries.coeff i (powerSeriesApproximant E V hsep z b).1 = + PowerSeries.coeff i (powerSeriesApproximant E V hsep z a).1 := by + induction b with + | zero => + have ha : a = 0 := Nat.eq_zero_of_le_zero hab + subst a + omega + | succ b ih => + by_cases hab' : a = b + 1 + · subst a + rfl + · have hab0 : a ≤ b := Nat.le_of_lt_succ (lt_of_le_of_ne hab hab') + calc + PowerSeries.coeff i + (powerSeriesApproximant E V hsep z (b + 1)).1 = + PowerSeries.coeff i + (powerSeriesApproximant E V hsep z b).1 := + powerSeriesApproximant_succ_coeff E V hsep z b i + (lt_of_lt_of_le hi hab0) + _ = PowerSeries.coeff i + (powerSeriesApproximant E V hsep z a).1 := ih hab0 + +/-- The power series obtained by taking the stable coefficient at every +stage of the successive approximation. -/ +private noncomputable def powerSeriesExpansion + (hsep : Algebra.IsSeparable E (K V)) + (z : AdicCompletion (m V) V) : PowerSeries (K V) := + PowerSeries.mk fun n ↦ + PowerSeries.coeff n (powerSeriesApproximant E V hsep z (n + 1)) + +/-- The assembled expansion has the same first `n` coefficients as the +`n`-th approximant. -/ +private theorem powerSeriesExpansion_coeff_eq_approximant + (hsep : Algebra.IsSeparable E (K V)) + (z : AdicCompletion (m V) V) {n i : ℕ} (hi : i < n) : + PowerSeries.coeff i (powerSeriesExpansion E V hsep z) = + PowerSeries.coeff i (powerSeriesApproximant E V hsep z n).1 := by + rw [powerSeriesExpansion, PowerSeries.coeff_mk] + exact (powerSeriesApproximant_coeff_stable E V hsep z + (a := i + 1) (b := n) (i := i) + (Nat.succ_le_iff.mpr hi) (Nat.lt_succ_self i)).symm + +/-- Every compatible adic family admits an expansion in the chosen +uniformizer with coefficients in the completed residue-field section. -/ +def CompletedDVRPowerSeriesSurjectivity + (hsep : Algebra.IsSeparable E (K V)) : Prop := + Function.Surjective (completedDVRPowerSeriesMap E V hsep) + +/-- Successive approximation supplies the expansion theorem. -/ +theorem completedDVRPowerSeriesMap_surjective + (hsep : Algebra.IsSeparable E (K V)) : + CompletedDVRPowerSeriesSurjectivity E V hsep := by + intro z + refine ⟨powerSeriesExpansion E V hsep z, ?_⟩ + apply AdicCompletion.ext + intro n + rw [eval_completedDVRPowerSeriesMap] + change Polynomial.eval₂ + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) + (PowerSeries.trunc n (powerSeriesExpansion E V hsep z)) = z.val n + calc + Polynomial.eval₂ + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) + (PowerSeries.trunc n (powerSeriesExpansion E V hsep z)) = + Polynomial.eval₂ + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) + (PowerSeries.trunc n (powerSeriesApproximant E V hsep z n)) := by + apply eval₂_eq_of_coeff_eq_of_pow_eq_zero + (completionCoordinateSection E V hsep n).toRingHom + (uniformizerCoordinate V n) n + (uniformizerCoordinate_pow_eq_zero V n) + intro d hd + rw [PowerSeries.coeff_trunc, if_pos hd, + PowerSeries.coeff_trunc, if_pos hd] + exact powerSeriesExpansion_coeff_eq_approximant E V hsep z hd + _ = powerSeriesCoordinateMap E V hsep n + (powerSeriesApproximant E V hsep z n) := rfl + _ = z.val n := (powerSeriesApproximant E V hsep z n).property + +/-- A supplied surjectivity proof turns the constructed map into the literal +power-series equivalence. -/ +def completedDVRPowerSeriesEquivOfSurjective + (hsep : Algebra.IsSeparable E (K V)) + (hsurj : CompletedDVRPowerSeriesSurjectivity E V hsep) : + PowerSeries (K V) ≃+* AdicCompletion (m V) V := + RingEquiv.ofBijective (completedDVRPowerSeriesMap E V hsep) + ⟨completedDVRPowerSeriesMap_injective E V hsep, hsurj⟩ + +end CompleteDVR + +section RetainedDVR + +private abbrev SourceDVR (E : Type u) [Field E] := + CoordinateZeroLocalRing E + +/-- The chosen-coordinate power-series map for the retained DVR place. -/ +def retainedCompletedDVRPowerSeriesMap + (E : Type u) [Field E] [CharZero E] + {L : Type u} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + PowerSeries (ResidueField D.valuation.toSubring) →+* + AdicCompletion (maximalIdeal D.valuation.toSubring) + D.valuation.toSubring := by + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + exact completedDVRPowerSeriesMap E D.valuation.toSubring + (relativeResidue_isSeparable E D) + +/-- The retained completed-DVR power-series map is injective. -/ +theorem retainedCompletedDVRPowerSeriesMap_injective + (E : Type u) [Field E] [CharZero E] + {L : Type u} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + Function.Injective (retainedCompletedDVRPowerSeriesMap E D) := by + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + exact completedDVRPowerSeriesMap_injective E D.valuation.toSubring + (relativeResidue_isSeparable E D) + +end RetainedDVR + + +end + +end Stafford38.Geometry.CompletedDVRPowerSeries diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ComponentFunctionFieldBoundary.lean b/LeanPool/Stafford38/Stafford38/Geometry/ComponentFunctionFieldBoundary.lean new file mode 100644 index 0000000000..cf85119e3a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ComponentFunctionFieldBoundary.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.FieldTheory.FunctionField +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveValuationNormalization +import LeanPool.Stafford38.Stafford38.Geometry.RelativeFractionFieldTransport +import LeanPool.Stafford38.Stafford38.Geometry.RelativeRetainedBoundaryPlace + +/-! +# Discrete boundary places for affine components + +An affine component function field is finitely generated over the ground +field. Therefore every transcendental component coordinate admits the +discrete boundary refinement constructed by the relative divisorial tower. +-/ + +namespace Stafford38.Geometry.ComponentFunctionFieldBoundary + +open IsLocalRing +open AlgebraicAnalysis.FunctionField +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeFractionFieldTransport +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace + +noncomputable section + + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The function field of a prime affine component is finitely generated as a +field extension of the ground field. -/ +theorem componentFunctionField_fg + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + (⊤ : IntermediateField k + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal))).FG := by + exact top_fg_of_finiteType_fractionRing k + (MvPolynomial (Fin m) k ⧸ P.asIdeal) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + +/-- The affine component point in homogeneous coordinates. -/ +def componentProjectivePoint + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + Fin (m + 1) → FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal) := + Fin.cases 1 fun i ↦ componentCoordinate P i + +/-- The stronger retained form preserves the actual coordinate-local algebra +map required by the completed-DVR machinery. -/ +theorem exists_relativeRetainedBoundaryPlace_componentCoordinate + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (hi : Transcendental k (componentCoordinate P i)) : + Nonempty + (Data k (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + (componentCoordinate P i)) := by + exact exists_data_of_fg_charZero k (componentFunctionField_fg P) + (componentCoordinate P i) hi + +/-- The complete affine coordinate family can be scaled into the retained +valuation ring with one projective coordinate equal to one. The selected +coordinate remains the retained parameter times the homogeneous zeroth +coordinate. -/ +theorem exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (hi : Transcendental k (componentCoordinate P i)) : + ∃ W : Data k (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + (componentCoordinate P i), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) := + W.ambientAlgebra + ∃ (chart : Fin (m + 1)) + (q : Fin (m + 1) → W.place.valuation.toSubring) + (scale : FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)), + scale ≠ 0 ∧ q chart = 1 ∧ q 0 ≠ 0 ∧ + (∀ a, (q a : FractionRing + (MvPolynomial (Fin m) k ⧸ P.asIdeal)) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ i) = q 0 * W.place.parameter := by + obtain ⟨W⟩ := + exists_relativeRetainedBoundaryPlace_componentCoordinate P i hi + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) := + W.ambientAlgebra + obtain ⟨chart, q, scale, hscale, hchart, hq⟩ := + exists_normalized_projective_lift W.place.valuation + (componentProjectivePoint P) ⟨0, by simp [componentProjectivePoint]⟩ + have hqzero : q 0 ≠ 0 := by + intro hzero + apply hscale + have h := hq 0 + rw [hzero] at h + simpa [componentProjectivePoint] using h.symm + refine ⟨W, chart, q, scale, hscale, hchart, hqzero, hq, ?_⟩ + apply Subtype.ext + change (q (Fin.succ i) : FractionRing + (MvPolynomial (Fin m) k ⧸ P.asIdeal)) = + (q 0 : FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) * + (W.place.parameter : FractionRing + (MvPolynomial (Fin m) k ⧸ P.asIdeal)) + rw [hq, hq, W.parameter_eq_coordinate] + simp [componentProjectivePoint] + +/-- A transcendental coordinate on a prime affine component has a genuine +discrete valuation place centred at coordinate zero. It is the forgetful +image of the retained relative place above. -/ +theorem exists_discreteBoundaryRefinement_componentCoordinate + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (hi : Transcendental k (componentCoordinate P i)) : + Nonempty (DiscreteBoundaryRefinement k (componentCoordinate P i)) := by + obtain ⟨W⟩ := + exists_relativeRetainedBoundaryPlace_componentCoordinate P i hi + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal)) := + W.ambientAlgebra + exact ⟨W.toDiscreteBoundaryRefinement⟩ + + +end + + +end Stafford38.Geometry.ComponentFunctionFieldBoundary diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosure.lean b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosure.lean new file mode 100644 index 0000000000..b3f35e5020 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosure.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.LocalizedProjectiveChartTransition + +/-! +# The projective cone of an affine component + +For a prime affine component with function field `F`, this file evaluates +homogeneous coordinates on the generic cone point + +`(T, x₀ T, ..., x_{m-1} T) ∈ F[T]^(m+1)`. + +The kernel is a prime homogeneous-coordinate ideal, saturated by the zeroth +coordinate. Zeroth-chart dehomogenization recovers the affine component ideal +exactly. +-/ + +namespace Stafford38.Geometry.ComponentProjectiveClosure + +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.LocalizedProjectiveChartTransition + +noncomputable section + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The function field of the prime affine component `P`. -/ +abbrev ComponentFractionField + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) := + FractionRing (MvPolynomial (Fin m) k ⧸ P.asIdeal) + +/-- Evaluation on the generic affine cone over a prime component: +`X₀ ↦ T` and `X_(j+1) ↦ x_j T`. -/ +def componentProjectiveConeMap + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + MvPolynomial (Fin (m + 1)) k →+* Polynomial (ComponentFractionField P) := + MvPolynomial.eval₂Hom + ((Polynomial.C : ComponentFractionField P →+* Polynomial + (ComponentFractionField P)).comp (algebraMap k (ComponentFractionField P))) + (Fin.cases Polynomial.X fun j ↦ + Polynomial.C (componentCoordinate P j) * Polynomial.X) + +/-- The homogeneous-coordinate ideal of the generic projective cone point. -/ +def componentProjectiveClosureIdeal + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + Ideal (MvPolynomial (Fin (m + 1)) k) := + RingHom.ker (componentProjectiveConeMap P) + +/-- Evaluation at the generic point of the affine component. -/ +def componentAffineGenericPointMap + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + MvPolynomial (Fin m) k →+* ComponentFractionField P := + (algebraMap (MvPolynomial (Fin m) k ⧸ P.asIdeal) + (ComponentFractionField P)).comp + (Ideal.Quotient.mk P.asIdeal) + +@[simp] +theorem componentAffineGenericPointMap_X + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (j : Fin m) : + componentAffineGenericPointMap P (MvPolynomial.X j) = + componentCoordinate P j := by + rfl + +/-- Generic-point evaluation agrees with multivariate evaluation at the +component coordinates. -/ +theorem componentAffineGenericPointMap_eq_eval₂ + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (f : MvPolynomial (Fin m) k) : + componentAffineGenericPointMap P f = + MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (fun j ↦ componentCoordinate P j) f := by + rw [MvPolynomial.map_mvPolynomial_eq_eval₂ + (componentAffineGenericPointMap P) f] + apply MvPolynomial.eval₂Hom_congr + · ext c + exact IsScalarTower.algebraMap_apply k + (MvPolynomial (Fin m) k ⧸ P.asIdeal) (ComponentFractionField P) c + · funext j + rfl + · rfl + +/-- Every equation of the affine component vanishes at its generic point. -/ +theorem componentAffineGenericPointMap_eq_zero_of_mem + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {f : MvPolynomial (Fin m) k} (hf : f ∈ P.asIdeal) : + componentAffineGenericPointMap P f = 0 := by + change algebraMap (MvPolynomial (Fin m) k ⧸ P.asIdeal) + (ComponentFractionField P) (Ideal.Quotient.mk P.asIdeal f) = 0 + rw [Ideal.Quotient.eq_zero_iff_mem.mpr hf, map_zero] + +/-- The generic-point map has exactly the prime component as its kernel. -/ +theorem componentAffineGenericPointMap_ker + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + RingHom.ker (componentAffineGenericPointMap P) = P.asIdeal := by + apply le_antisymm + · intro f hf + have hzero : Ideal.Quotient.mk P.asIdeal f = 0 := by + apply IsFractionRing.injective + (MvPolynomial (Fin m) k ⧸ P.asIdeal) (ComponentFractionField P) + simpa only [map_zero, RingHom.mem_ker, + componentAffineGenericPointMap, RingHom.comp_apply] using hf + exact Ideal.Quotient.eq_zero_iff_mem.mp hzero + · intro f hf + exact componentAffineGenericPointMap_eq_zero_of_mem P hf + +@[simp] +theorem componentProjectiveConeMap_X_zero + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + componentProjectiveConeMap P (MvPolynomial.X 0) = Polynomial.X := by + simp [componentProjectiveConeMap] + +@[simp] +theorem componentProjectiveConeMap_X_succ + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (j : Fin m) : + componentProjectiveConeMap P (MvPolynomial.X (Fin.succ j)) = + Polynomial.C (componentCoordinate P j) * Polynomial.X := by + simp [componentProjectiveConeMap] + +/-- The cone kernel is prime because its target is a polynomial ring over the +component function field. -/ +theorem componentProjectiveClosureIdeal_isPrime + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + (componentProjectiveClosureIdeal P).IsPrime := by + exact RingHom.ker_isPrime (componentProjectiveConeMap P) + +/-- The cone kernel is saturated by the homogeneous zeroth coordinate. This +is the scheme-free saturation property needed at the projective boundary. -/ +theorem componentProjectiveClosureIdeal_colon_zeroCoordinate + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + (componentProjectiveClosureIdeal P).colon + ({MvPolynomial.X 0} : + Set (MvPolynomial (Fin (m + 1)) k)) = + componentProjectiveClosureIdeal P := by + ext H + rw [Submodule.mem_colon_singleton] + change componentProjectiveConeMap P (H * MvPolynomial.X 0) = 0 ↔ + componentProjectiveConeMap P H = 0 + rw [map_mul, componentProjectiveConeMap_X_zero] + constructor + · intro h + apply Polynomial.ext + intro n + have hn := congrArg + (fun q : Polynomial (ComponentFractionField P) ↦ q.coeff (n + 1)) h + simpa using hn + · intro h + rw [h, zero_mul] + +/-- Scaling every variable of a homogeneous multivariate polynomial by the +same scalar extracts the corresponding power of that scalar. -/ +theorem eval₂_mul_common_of_isHomogeneous + {R S : Type*} [CommSemiring R] [CommSemiring S] + {σ : Type*} {p : MvPolynomial σ R} {d : ℕ} + (hp : p.IsHomogeneous d) (f : R →+* S) (x : σ → S) (t : S) : + MvPolynomial.eval₂ f (fun i ↦ x i * t) p = + MvPolynomial.eval₂ f x p * t ^ d := by + classical + rw [MvPolynomial.eval₂_eq, MvPolynomial.eval₂_eq, Finset.sum_mul] + apply Finset.sum_congr rfl + intro a ha + have hdegree : a.degree = d := by + rw [Finsupp.degree_eq_weight_one] + exact hp (MvPolynomial.mem_support_iff.mp ha) + rw [mul_assoc] + congr 1 + simp_rw [mul_pow] + rw [Finset.prod_mul_distrib, Finset.prod_pow_eq_pow_sum] + change (∏ i ∈ a.support, x i ^ a i) * t ^ a.degree = _ + rw [hdegree] + +/-- Evaluation after zeroth-chart dehomogenization is evaluation at the +projective point `(1,y)`, allowing a larger target coefficient ring. -/ +theorem eval₂_projectiveDehomogenize + {S : Type*} [CommSemiring S] (f : k →+* S) (y : Fin m → S) + (H : MvPolynomial (Fin (m + 1)) k) : + MvPolynomial.eval₂ f y + (Stafford38.Geometry.ProjectiveEquationFormalChart.projectiveDehomogenize H) = + MvPolynomial.eval₂ f (Fin.cases 1 y) H := by + rw [show + Stafford38.Geometry.ProjectiveEquationFormalChart.projectiveDehomogenize H = + MvPolynomial.bind₁ + (Fin.cases 1 fun i ↦ MvPolynomial.X i) H by rfl] + change MvPolynomial.eval₂Hom f y + (MvPolynomial.bind₁ (Fin.cases 1 fun i ↦ MvPolynomial.X i) H) = _ + rw [MvPolynomial.eval₂Hom_bind₁] + apply MvPolynomial.eval₂_congr + intro i + refine Fin.cases ?_ (fun j ↦ ?_) i <;> simp + +/-- Evaluating a homogeneous projective polynomial on the generic cone point +is dehomogenized evaluation times the expected power of `T`. -/ +theorem componentProjectiveConeMap_eq_eval₂_mul_X_pow_of_isHomogeneous + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ} + (hH : H.IsHomogeneous d) : + componentProjectiveConeMap P H = + Polynomial.C + (MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (Fin.cases 1 fun j ↦ componentCoordinate P j) H) * + Polynomial.X ^ d := by + change MvPolynomial.eval₂ + ((Polynomial.C : ComponentFractionField P →+* Polynomial + (ComponentFractionField P)).comp (algebraMap k (ComponentFractionField P))) + (Fin.cases Polynomial.X fun j ↦ + Polynomial.C (componentCoordinate P j) * Polynomial.X) H = _ + let coords : Fin (m + 1) → ComponentFractionField P := + Fin.cases 1 fun j ↦ componentCoordinate P j + have hvars : + (fun a ↦ Polynomial.C (coords a) * Polynomial.X) = + Fin.cases Polynomial.X + (fun j ↦ Polynomial.C (componentCoordinate P j) * Polynomial.X) := by + funext a + refine Fin.cases ?_ (fun j ↦ ?_) a + · simp [coords] + · simp [coords] + rw [← hvars] + have hscale := eval₂_mul_common_of_isHomogeneous hH + ((Polynomial.C : ComponentFractionField P →+* Polynomial + (ComponentFractionField P)).comp (algebraMap k (ComponentFractionField P))) + (fun a ↦ Polynomial.C (coords a)) Polynomial.X + rw [hscale] + congr 1 + exact (MvPolynomial.map_eval₂Hom + (algebraMap k (ComponentFractionField P)) coords Polynomial.C H).symm + +/-- The cone-map image of the standard homogenization is generic affine +evaluation times the expected power of `T`. -/ +theorem componentProjectiveConeMap_homogenizeAtZero + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (f : MvPolynomial (Fin m) k) : + componentProjectiveConeMap P (homogenizeAtZero f) = + Polynomial.C (componentAffineGenericPointMap P f) * + Polynomial.X ^ f.totalDegree := by + rw [componentProjectiveConeMap_eq_eval₂_mul_X_pow_of_isHomogeneous P + (homogenizeAtZero_isHomogeneous f)] + congr 1 + rw [componentAffineGenericPointMap_eq_eval₂] + have heval := eval₂_projectiveDehomogenize + (algebraMap k (ComponentFractionField P)) + (fun j ↦ componentCoordinate P j) (homogenizeAtZero f) + rw [projectiveDehomogenize_homogenizeAtZero] at heval + exact congrArg Polynomial.C heval.symm + +/-- Setting the cone parameter to one recovers generic-point evaluation in +the zeroth affine chart. -/ +theorem componentProjectiveConeMap_eval_one + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (H : MvPolynomial (Fin (m + 1)) k) : + Polynomial.eval 1 (componentProjectiveConeMap P H) = + componentAffineGenericPointMap P + (Stafford38.Geometry.ProjectiveEquationFormalChart.projectiveDehomogenize H) := by + rw [componentAffineGenericPointMap_eq_eval₂] + rw [eval₂_projectiveDehomogenize] + change Polynomial.evalRingHom 1 + (MvPolynomial.eval₂ + ((Polynomial.C : ComponentFractionField P →+* Polynomial + (ComponentFractionField P)).comp + (algebraMap k (ComponentFractionField P))) + (Fin.cases Polynomial.X fun j ↦ + Polynomial.C (componentCoordinate P j) * Polynomial.X) H) = _ + rw [MvPolynomial.eval₂_comp_left] + change MvPolynomial.eval₂Hom _ _ H = MvPolynomial.eval₂Hom _ _ H + apply MvPolynomial.eval₂Hom_congr + · ext c + simp + · funext i + refine Fin.cases ?_ (fun j ↦ ?_) i <;> simp + · rfl + +/-- Every homogeneous-coordinate equation in the cone kernel dehomogenizes +to an equation of the original affine component. -/ +theorem projectiveDehomogenize_mem_of_mem_componentProjectiveClosureIdeal + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {H : MvPolynomial (Fin (m + 1)) k} + (hH : H ∈ componentProjectiveClosureIdeal P) : + Stafford38.Geometry.ProjectiveEquationFormalChart.projectiveDehomogenize H ∈ + P.asIdeal := by + rw [← componentAffineGenericPointMap_ker P, RingHom.mem_ker] + rw [← componentProjectiveConeMap_eval_one P H] + have hzero : componentProjectiveConeMap P H = 0 := by + exact hH + rw [hzero] + simp + +/-- Every affine equation of the component yields a homogeneous equation of +its projective cone. -/ +theorem homogenizeAtZero_mem_componentProjectiveClosureIdeal + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {f : MvPolynomial (Fin m) k} (hf : f ∈ P.asIdeal) : + homogenizeAtZero f ∈ componentProjectiveClosureIdeal P := by + rw [componentProjectiveClosureIdeal, RingHom.mem_ker, + componentProjectiveConeMap_homogenizeAtZero, + componentAffineGenericPointMap_eq_zero_of_mem P hf, Polynomial.C_0, + zero_mul] + + +end + +end Stafford38.Geometry.ComponentProjectiveClosure diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosureNormalization.lean b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosureNormalization.lean new file mode 100644 index 0000000000..9cdcdc6dfd --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveClosureNormalization.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ComponentFunctionFieldBoundary +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosure +import LeanPool.Stafford38.Stafford38.Geometry.RetainedProjectiveCompletion +import Mathlib.RingTheory.LaurentSeries + +/-! +# Projective-component equations under retained normalization + +A homogeneous equation of the generic projective cone continues to vanish +after a common rescaling of all projective coordinates into a subring of the +component function field. The proof first checks the equality in the function +field and then reflects it through the injective subring map. Consequently the +equality is preserved by every subsequent ring homomorphism, including the +retained completion and its Laurent-series embedding. + +This is only a homogeneous projective statement. It does not assert that an +arbitrary affine chart point satisfies the original affine component ideal. +-/ + +namespace Stafford38.Geometry.ComponentProjectiveClosureNormalization + +open IsLocalRing +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedProjectiveCompletion + +noncomputable section + + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- A homogeneous projective-cone equation vanishes after any common-scale +lift through an injective coefficient ring. The explicit coefficient +compatibility prevents an implicit change of the ground-field embedding. -/ +theorem eval₂_eq_zero_of_commonScale_componentProjectivePoint + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {V : Type u} [CommRing V] + (coeff : k →+* V) (ι : V →+* ComponentFractionField P) + (hι : Function.Injective ι) + (hcoeff : ι.comp coeff = algebraMap k (ComponentFractionField P)) + {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ} + (hhomogeneous : H.IsHomogeneous d) + (hH : H ∈ componentProjectiveClosureIdeal P) + (q : Fin (m + 1) → V) (scale : ComponentFractionField P) + (hq : ∀ a, ι (q a) = scale * componentProjectivePoint P a) : + MvPolynomial.eval₂ coeff q H = 0 := by + have hgeneric : + MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (componentProjectivePoint P) H = 0 := by + have hcone : componentProjectiveConeMap P H = 0 := hH + have hformula := + componentProjectiveConeMap_eq_eval₂_mul_X_pow_of_isHomogeneous + P hhomogeneous + rw [hcone] at hformula + have hone := congrArg (Polynomial.eval 1) hformula + have hpt : componentProjectivePoint P = + Fin.cases 1 fun i ↦ componentCoordinate P i := rfl + simpa [hpt] using hone.symm + apply hι + rw [map_zero] + calc + ι (MvPolynomial.eval₂ coeff q H) = + MvPolynomial.eval₂ (ι.comp coeff) (fun a ↦ ι (q a)) H := + MvPolynomial.map_eval₂Hom coeff q ι H + _ = MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (fun a ↦ componentProjectivePoint P a * scale) H := by + apply MvPolynomial.eval₂Hom_congr hcoeff + · funext a + rw [hq a, mul_comm] + · rfl + _ = MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (componentProjectivePoint P) H * scale ^ d := + eval₂_mul_common_of_isHomogeneous hhomogeneous + (algebraMap k (ComponentFractionField P)) + (componentProjectivePoint P) scale + _ = 0 := by rw [hgeneric, zero_mul] + +/-- Evaluation is natural under every ring homomorphism out of a common-scale +lift: the target coefficient map and every target coordinate are the displayed +composites, and the resulting target-ring evaluation is zero. -/ +theorem map_eval₂_eq_zero_of_commonScale_componentProjectivePoint + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {V S : Type u} [CommRing V] [CommRing S] + (coeff : k →+* V) (ι : V →+* ComponentFractionField P) + (hι : Function.Injective ι) + (hcoeff : ι.comp coeff = algebraMap k (ComponentFractionField P)) + (ψ : V →+* S) + {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ} + (hhomogeneous : H.IsHomogeneous d) + (hH : H ∈ componentProjectiveClosureIdeal P) + (q : Fin (m + 1) → V) (scale : ComponentFractionField P) + (hq : ∀ a, ι (q a) = scale * componentProjectivePoint P a) : + MvPolynomial.eval₂ (ψ.comp coeff) (fun a ↦ ψ (q a)) H = 0 := by + calc + MvPolynomial.eval₂ (ψ.comp coeff) (fun a ↦ ψ (q a)) H = + ψ (MvPolynomial.eval₂ coeff q H) := by + simpa only [Function.comp_apply, Function.comp_def] using + (MvPolynomial.eval₂_comp_left ψ coeff q H).symm + _ = 0 := by + rw [eval₂_eq_zero_of_commonScale_componentProjectivePoint P coeff ι hι + hcoeff hhomogeneous hH q scale hq, map_zero] + +/-- The coefficient map from the ground field into a retained component +valuation ring. -/ +def retainedComponentCoefficientMap + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + k →+* W.place.valuation.toSubring := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + exact (relativeCoefficientMap W.coefficientField W.place).comp + (algebraMap k W.coefficientField) + +/-- Every homogeneous equation of the projective component vanishes on a +common-scale lift in the retained valuation subring. -/ +theorem retained_eval₂_eq_zero_of_commonScale + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + ∀ {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ}, + H.IsHomogeneous d → H ∈ componentProjectiveClosureIdeal P → + ∀ (q : Fin (m + 1) → W.place.valuation.toSubring) + (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + MvPolynomial.eval₂ (retainedComponentCoefficientMap P i W) q H = 0 := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + letI : IsScalarTower W.coefficientField + (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.coefficientTower + intro H d hhomogeneous hH q scale hq + let V := W.place.valuation.toSubring + let coeff : k →+* V := retainedComponentCoefficientMap P i W + have hcoeff : W.place.valuation.toSubring.subtype.comp coeff = + algebraMap k (ComponentFractionField P) := by + ext c + change ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : ComponentFractionField P) = + algebraMap k (ComponentFractionField P) c + calc + ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : + ComponentFractionField P) = + algebraMap W.coefficientField (ComponentFractionField P) + (algebraMap k W.coefficientField c) := + DFunLike.congr_fun + (relativeCoefficientMap_commutes W.coefficientField W.place) + (algebraMap k W.coefficientField c) + _ = algebraMap k (ComponentFractionField P) c := + IsScalarTower.algebraMap_apply k W.coefficientField + (ComponentFractionField P) c + exact eval₂_eq_zero_of_commonScale_componentProjectivePoint + P coeff W.place.valuation.toSubring.subtype + Subtype.val_injective hcoeff hhomogeneous hH q scale hq + +/-- The explicit ground-field coefficient map in the completed power-series +chart. No ambient `Algebra k` instance is selected implicitly. -/ +def retainedCompletedCoefficientMap + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + k →+* PowerSeries (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact (retainedToCompletedPowerSeries W).comp + (retainedComponentCoefficientMap P i W) + +/-- The same equation vanishes when evaluated at the transported completed +coordinates with the explicit transported coefficient map. -/ +theorem retainedCompleted_eval₂_eq_zero_of_commonScale + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ}, + H.IsHomogeneous d → H ∈ componentProjectiveClosureIdeal P → + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + MvPolynomial.eval₂ (retainedCompletedCoefficientMap P i W) + (fun a ↦ retainedToCompletedPowerSeries W (q a)) H = 0 := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro H d hhomogeneous hH q scale hq + change MvPolynomial.eval₂ + ((retainedToCompletedPowerSeries W).comp + (retainedComponentCoefficientMap P i W)) + (fun a ↦ retainedToCompletedPowerSeries W (q a)) H = 0 + calc + _ = retainedToCompletedPowerSeries W + (MvPolynomial.eval₂ (retainedComponentCoefficientMap P i W) q H) := by + simpa only [Function.comp_apply, Function.comp_def] using + (MvPolynomial.eval₂_comp_left (retainedToCompletedPowerSeries W) + (retainedComponentCoefficientMap P i W) q H).symm + _ = 0 := by + rw [retained_eval₂_eq_zero_of_commonScale P i W + hhomogeneous hH q scale hq, map_zero] + +/-- The explicit ground-field coefficient map after the retained completion +and canonical Laurent-series embedding. -/ +def retainedLaurentCoefficientMap + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + k →+* LaurentSeries (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact (algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V))).comp + (retainedCompletedCoefficientMap P i W) + +/-- The completed equation remains zero when evaluated at the corresponding +Laurent coordinates. -/ +theorem retainedLaurent_eval₂_eq_zero_of_commonScale + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ {H : MvPolynomial (Fin (m + 1)) k} {d : ℕ}, + H.IsHomogeneous d → H ∈ componentProjectiveClosureIdeal P → + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + MvPolynomial.eval₂ (retainedLaurentCoefficientMap P i W) + (fun a ↦ algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W (q a))) H = 0 := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro H d hhomogeneous hH q scale hq + let ψ : PowerSeries (ResidueField V) →+* LaurentSeries (ResidueField V) := + algebraMap (PowerSeries (ResidueField V)) (LaurentSeries (ResidueField V)) + change MvPolynomial.eval₂ + (ψ.comp (retainedCompletedCoefficientMap P i W)) + (fun a ↦ ψ (retainedToCompletedPowerSeries W (q a))) H = 0 + calc + _ = ψ (MvPolynomial.eval₂ (retainedCompletedCoefficientMap P i W) + (fun a ↦ retainedToCompletedPowerSeries W (q a)) H) := by + simpa only [Function.comp_apply, Function.comp_def] using + (MvPolynomial.eval₂_comp_left ψ + (retainedCompletedCoefficientMap P i W) + (fun a ↦ retainedToCompletedPowerSeries W (q a)) H).symm + _ = 0 := by + rw [retainedCompleted_eval₂_eq_zero_of_commonScale P i W + hhomogeneous hH q scale hq, map_zero] + + +end + +end Stafford38.Geometry.ComponentProjectiveClosureNormalization diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveOrder.lean b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveOrder.lean new file mode 100644 index 0000000000..d0e8f41233 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ComponentProjectiveOrder.lean @@ -0,0 +1,308 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalBaseVariety +import LeanPool.Stafford38.Stafford38.Geometry.ComponentFunctionFieldBoundary +import LeanPool.Stafford38.Stafford38.Geometry.RetainedProjectiveCompletion +import Mathlib.RingTheory.Nullstellensatz + +/-! +# Vanishing of the normalized projective denominator + +Axis avoidance makes the distinguished affine coordinate a unit on every +component of the reduced base variety. At the retained boundary place that +coordinate is a nonunit. Consequently, a common projective normalization of +all affine coordinates cannot have unit homogeneous denominator. +-/ + +namespace Stafford38.Geometry.ComponentProjectiveOrder + +open IsLocalRing +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedProjectiveCompletion +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u v + +/-- Support avoidance forces the contracted reduced base ideal and the +distinguished coordinate to generate the unit ideal. -/ +theorem reducedOrderBaseIdeal_sup_coordinate_eq_top_of_support_disjoint + {k : Type u} [Field k] [IsAlgClosed k] {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) : + reducedOrderBaseIdeal k I ⊔ + Ideal.span ({MvPolynomial.X i} : Set (MvPolynomial (Fin n) k)) = ⊤ := by + classical + let B := reducedOrderBaseIdeal k I + let J := B ⊔ Ideal.span + ({MvPolynomial.X i} : Set (MvPolynomial (Fin n) k)) + by_contra hJ + obtain ⟨M, hMmax, hJM⟩ := Ideal.exists_le_maximal J hJ + obtain ⟨y, hMy⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hMmax + have hyB : ∀ f ∈ B, MvPolynomial.eval y f = 0 := by + intro f hf + have hfM : f ∈ M := hJM (Ideal.mem_sup_left hf) + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hfM + exact hfM + have hyi : y i = 0 := by + have hXM : MvPolynomial.X i ∈ M := by + apply hJM + exact Ideal.mem_sup_right (Ideal.mem_span_singleton_self _) + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hXM + simpa using hXM + exact (coordinate_ne_zero_of_baseZero_of_support_disjoint + I i hdisjoint y hyB) hyi + +/-- On every component above the contracted base ideal, axis avoidance gives +an explicit polynomial inverse for the distinguished coordinate. -/ +theorem exists_componentCoordinate_polynomial_inverse + {k : Type u} [Field k] [IsAlgClosed k] {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (P : PrimeSpectrum (MvPolynomial (Fin n) k)) + (hBP : reducedOrderBaseIdeal k I ≤ P.asIdeal) : + ∃ g : MvPolynomial (Fin n) k, + MvPolynomial.X i * g - 1 ∈ P.asIdeal := by + classical + let B := reducedOrderBaseIdeal k I + have htop := reducedOrderBaseIdeal_sup_coordinate_eq_top_of_support_disjoint + I i hdisjoint + have hone : (1 : MvPolynomial (Fin n) k) ∈ + B ⊔ Ideal.span ({MvPolynomial.X i} : Set (MvPolynomial (Fin n) k)) := by + rw [htop] + exact Submodule.mem_top + obtain ⟨b, hb, z, hz, hbz⟩ := Submodule.mem_sup.mp hone + obtain ⟨g, hg⟩ := Ideal.mem_span_singleton.mp hz + refine ⟨g, ?_⟩ + have hbP : b ∈ P.asIdeal := hBP hb + rw [← Ideal.Quotient.eq_zero_iff_mem] + rw [map_sub, map_mul, map_one] + have hsum := congrArg (Ideal.Quotient.mk P.asIdeal) hbz + rw [map_add, map_one, Ideal.Quotient.eq_zero_iff_mem.mpr hbP] at hsum + have hzq : Ideal.Quotient.mk P.asIdeal z = + Ideal.Quotient.mk P.asIdeal (MvPolynomial.X i * g) := by + rw [hg] + rw [← map_mul, ← hzq] + apply sub_eq_zero.mpr + simpa using hsum + +/-- If a nonunit parameter has a polynomial inverse in affine coordinates, +then the common denominator of an integral projective normalization of those +coordinates is a nonunit. -/ +theorem normalized_denominator_nonunit_of_polynomial_inverse + {k : Type u} [Field k] {K : Type v} [Field K] [Algebra k K] + (V : ValuationSubring K) {n : ℕ} + (coeff : k →+* V) + (hcoeff : V.toSubring.subtype.comp coeff = algebraMap k K) + (x : Fin n → K) (qzero : V) (q : Fin n → V) (scale : K) + (hqzero : (qzero : K) = scale) + (hq : ∀ j, (q j : K) = scale * x j) + (i : Fin n) (parameter : V) + (hparameter : (parameter : K) = x i) + (hparameter_nonunit : ¬IsUnit parameter) + (g : MvPolynomial (Fin n) k) + (hinverse : x i * MvPolynomial.eval₂ (algebraMap k K) x g = 1) : + ¬IsUnit qzero := by + intro hqzero_unit + obtain ⟨u, hu⟩ := hqzero_unit + let xV : Fin n → V := fun j ↦ q j * (↑(u⁻¹) : V) + have hxV : ∀ j, (xV j : K) = x j := by + intro j + have huK : ((u : V) : K) = scale := + (congrArg (fun z : V ↦ (z : K)) hu).trans hqzero + have huinvK : ((u : V) : K) * (((↑(u⁻¹) : V) : K)) = 1 := by + have huinvV : (u : V) * (↑(u⁻¹) : V) = 1 := + (Units.mul_inv_eq_one).2 rfl + change ((((u : V) * (↑(u⁻¹) : V) : V) : K)) = 1 + rw [huinvV] + exact map_one V.toSubring.subtype + change ((q j : V) : K) * (((↑(u⁻¹) : V) : K)) = x j + calc + ((q j : V) : K) * (((↑(u⁻¹) : V) : K)) = + (scale * x j) * (((↑(u⁻¹) : V) : K)) := by rw [hq j] + _ = x j * (((u : V) : K) * (((↑(u⁻¹) : V) : K))) := by + rw [huK] + ring + _ = x j := by rw [huinvK, mul_one] + let gV : V := MvPolynomial.eval₂Hom coeff xV g + have hgV : (gV : K) = MvPolynomial.eval₂ (algebraMap k K) x g := by + calc + (gV : K) = MvPolynomial.eval₂Hom + (V.toSubring.subtype.comp coeff) (fun j ↦ (xV j : K)) g := + MvPolynomial.map_eval₂Hom coeff xV V.toSubring.subtype g + _ = MvPolynomial.eval₂Hom (algebraMap k K) x g := by + apply MvPolynomial.eval₂Hom_congr hcoeff + · funext j + exact hxV j + · rfl + _ = MvPolynomial.eval₂ (algebraMap k K) x g := rfl + apply hparameter_nonunit + rw [isUnit_iff_exists_inv] + refine ⟨gV, ?_⟩ + apply Subtype.ext + change (parameter : K) * (gV : K) = (1 : V) + simpa [hparameter, hgV] using hinverse + +/-- The denominator in the retained normalization of a component point is a +nonunit whenever the ambient support avoids the selected coordinate axis. -/ +theorem normalizedComponentProjectivePoint_zero_nonunit + {k : Type u} [Field k] [IsAlgClosed k] {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (P : PrimeSpectrum (MvPolynomial (Fin n) k)) + (hBP : reducedOrderBaseIdeal k I ≤ P.asIdeal) + (W : Data k (FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)) + (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)) := + W.ambientAlgebra + ∀ (q : Fin (n + 1) → W.place.valuation.toSubring) + (scale : FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)), + (∀ a, (q a : FractionRing + (MvPolynomial (Fin n) k ⧸ P.asIdeal)) = + scale * componentProjectivePoint P a) → + ¬IsUnit (q 0) := by + let F := FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal) + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) F := + W.ambientAlgebra + intro q scale hq + letI : IsScalarTower W.coefficientField + (CoordinateZeroLocalRing W.coefficientField) F := W.coefficientTower + let V := W.place.valuation.toSubring + obtain ⟨g, hg⟩ := exists_componentCoordinate_polynomial_inverse + I i hdisjoint P hBP + let phi : MvPolynomial (Fin n) k →+* F := + (algebraMap (MvPolynomial (Fin n) k ⧸ P.asIdeal) F).comp + (Ideal.Quotient.mk P.asIdeal) + have hphiC : phi.comp MvPolynomial.C = algebraMap k F := by + ext c + exact IsScalarTower.algebraMap_apply k + (MvPolynomial (Fin n) k ⧸ P.asIdeal) F c + have hphiX : ∀ j, phi (MvPolynomial.X j) = componentCoordinate P j := by + intro j + rfl + have hpoly : phi g = MvPolynomial.eval₂ (algebraMap k F) + (fun j ↦ componentCoordinate P j) g := by + rw [MvPolynomial.map_mvPolynomial_eq_eval₂ phi g] + change MvPolynomial.eval₂Hom (phi.comp MvPolynomial.C) + (fun j ↦ phi (MvPolynomial.X j)) g = + MvPolynomial.eval₂Hom (algebraMap k F) + (fun j ↦ componentCoordinate P j) g + apply MvPolynomial.eval₂Hom_congr hphiC + · funext j + exact hphiX j + · rfl + have hinverse : componentCoordinate P i * + MvPolynomial.eval₂ (algebraMap k F) + (fun j ↦ componentCoordinate P j) g = 1 := by + have hzero : phi (MvPolynomial.X i * g - 1) = 0 := by + have hmk : Ideal.Quotient.mk P.asIdeal + (MvPolynomial.X i * g - 1) = 0 := + Ideal.Quotient.eq_zero_iff_mem.mpr hg + simpa [phi] using (congrArg + (algebraMap (MvPolynomial (Fin n) k ⧸ P.asIdeal) F) hmk) + rw [map_sub, map_mul, map_one, sub_eq_zero, hphiX, hpoly] at hzero + exact hzero + let coeff : k →+* V := + (relativeCoefficientMap W.coefficientField W.place).comp + (algebraMap k W.coefficientField) + have hcoeff : W.place.valuation.toSubring.subtype.comp coeff = + algebraMap k F := by + ext c + change ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : F) = algebraMap k F c + calc + ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : F) = + algebraMap W.coefficientField F + (algebraMap k W.coefficientField c) := + DFunLike.congr_fun + (relativeCoefficientMap_commutes W.coefficientField W.place) + (algebraMap k W.coefficientField c) + _ = algebraMap k F c := + IsScalarTower.algebraMap_apply k W.coefficientField F c + apply normalized_denominator_nonunit_of_polynomial_inverse + (V := W.place.valuation) (coeff := coeff) hcoeff + (x := fun j ↦ componentCoordinate P j) + (qzero := q 0) (q := fun j ↦ q (Fin.succ j)) (scale := scale) + (i := i) (parameter := W.place.parameter) (g := g) + · simpa [componentProjectivePoint] using hq 0 + · intro j + simpa [componentProjectivePoint] using hq (Fin.succ j) + · exact W.parameter_eq_coordinate + · exact W.place.parameter_nonunit + · exact hinverse + +/-- The normalized homogeneous zeroth coordinate therefore vanishes in the +completed residue chart. -/ +theorem normalizedComponentProjectivePoint_zero_vanish + {k : Type u} [Field k] [CharZero k] [IsAlgClosed k] {n : ℕ} + (I : RightIdeal (PresentedWeyl k n)) (i : Fin n) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl i)} : Set (SymbolRing k n)))) + (P : PrimeSpectrum (MvPolynomial (Fin n) k)) + (hBP : reducedOrderBaseIdeal k I ≤ P.asIdeal) + (W : Data k (FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)) + (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)) := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ (q : Fin (n + 1) → W.place.valuation.toSubring) + (scale : FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)), + (∀ a, (q a : FractionRing + (MvPolynomial (Fin n) k ⧸ P.asIdeal)) = + scale * componentProjectivePoint P a) → + PowerSeries.constantCoeff + (retainedToCompletedPowerSeries W (q 0)) = 0 := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (FractionRing (MvPolynomial (Fin n) k ⧸ P.asIdeal)) := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro q scale hq + have hnonunit : ¬IsUnit (q 0) := + normalizedComponentProjectivePoint_zero_nonunit + I i hdisjoint P hBP W q scale hq + exact retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit W + (q 0) hnonunit + + +end + +end Stafford38.Geometry.ComponentProjectiveOrder diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ConormalAxisContradiction.lean b/LeanPool/Stafford38/Stafford38/Geometry/ConormalAxisContradiction.lean new file mode 100644 index 0000000000..f4708bcbba --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ConormalAxisContradiction.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.HomogeneousChart +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure + +/-! +# The pure-momentum axis obstruction + +The normalized canonical order symbol is homogeneous of ordinary total degree: +it is order-homogeneous and its proved fibre-only property removes every +weight-zero coordinate exponent. Its value at the distinguished pure-momentum +axis is therefore its normalized pure coefficient, namely one. + +Consequently that axis cannot belong to any checked affine zero locus contained +in the principal-symbol hypersurface. Applying the existing conditional +equation-conormal-closure containment gives the corresponding contradiction. +This file proves no conormal-axis producer and no Gabber theorem. +-/ + +namespace Stafford38.Geometry.ConormalAxisContradiction + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBW +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +variable {k : Type*} [Field k] {n N : ℕ} + +/-- An order-homogeneous fibre-only symbol is homogeneous for ordinary total +degree. -/ +theorem isHomogeneous_of_orderHomogeneous_of_isFibreOnly + {P : SymbolRing k n} + (horder : P.IsWeightedHomogeneous (@orderWeight n) N) + (hfibre : IsFibreOnly k P) : + P.IsHomogeneous N := by + intro m hm + have horder' := horder hm + rw [Finsupp.weight_apply] at horder' + rw [← horder'] + apply Finsupp.sum_congr + intro i hi + rcases i with i | i + · simp [orderWeight, fibreWeight, hfibre m hm i] + · simp [orderWeight, fibreWeight] + +/-- The canonical order principal symbol is homogeneous of ordinary total +degree `N`. -/ +theorem canonical_orderPrincipalComponent_isHomogeneous + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (presentedPrincipalComponent k orderWeight N d).IsHomogeneous N := by + apply isHomogeneous_of_orderHomogeneous_of_isFibreOnly + · simpa [presentedPrincipalComponent] using + (MvPolynomial.weightedHomogeneousComponent_isWeightedHomogeneous + (w := @orderWeight (n + 1)) (n := N) + (presentedNormalFormLinearEquiv k (n + 1) d)) + · exact canonical_orderPrincipalComponent_isFibreOnly k n N hd + +/-- A homogeneous polynomial with pure-axis coefficient one does not vanish at +that axis. -/ +theorem eval_axis_eq_one_of_pureCoefficient_one + (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) + (hpure : MvPolynomial.coeff (Finsupp.single t N) P = 1) : + MvPolynomial.eval (axisPoint k t) P = 1 := by + classical + rw [MvPolynomial.eval_eq] + rw [Finset.sum_eq_single (Finsupp.single t N)] + · rw [hpure, one_mul] + by_cases hN : N = 0 + · subst N + simp + · rw [Finsupp.support_single_ne_zero t hN] + simp [axisPoint] + · intro m hm hne + have hmcoeff : MvPolynomial.coeff m P ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + have hexists : ∃ i ∈ m.support, i ≠ t := by + by_contra hnot + have hsubset : m.support ⊆ {t} := by + intro i hi + simp only [Finset.mem_singleton] + by_contra hit + exact hnot ⟨i, hi, hit⟩ + have hmform : m = Finsupp.single t (m t) := + Finsupp.support_subset_singleton.mp hsubset + have hdegree : m.degree = N := by + rw [Finsupp.degree_eq_weight_one] + exact hP hmcoeff + rw [hmform, Finsupp.degree_single] at hdegree + apply hne + rw [hmform, hdegree] + rcases hexists with ⟨i, hi, hit⟩ + rw [Finset.prod_eq_zero hi, mul_zero] + rw [axisPoint, if_neg hit, zero_pow] + exact Finsupp.mem_support_iff.mp hi + · intro hnot + exact (hnot (MvPolynomial.mem_support_iff.mpr (hpure.trans_ne one_ne_zero))).elim + +/-- Direct set-level obstruction: if a checked affine locus lies in `V(P)`, +axis membership contradicts homogeneity and pure coefficient one. -/ +theorem false_of_axis_mem_of_subset_principal_zeroLocus + (t : PhaseVar n) {P : SymbolRing k n} + (hP : P.IsHomogeneous N) + (hpure : MvPolynomial.coeff (Finsupp.single t N) P = 1) + {S : Set (PhaseVar n → k)} + (hS : S ⊆ MvPolynomial.zeroLocus k (Ideal.span ({P} : Set (SymbolRing k n)))) + (haxis : axisPoint k t ∈ S) : False := by + have hzero := (MvPolynomial.mem_zeroLocus_iff.mp (hS haxis)) P + (Ideal.subset_span (Set.mem_singleton P)) + rw [MvPolynomial.aeval_eq_eval, + eval_axis_eq_one_of_pureCoefficient_one t hP hpure] at hzero + exact one_ne_zero hzero + +/-- The normalized canonical order symbol evaluates to one at the +distinguished pure-momentum axis. -/ +theorem canonical_orderPrincipalComponent_eval_pureMomentumAxis + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + MvPolynomial.eval + (axisPoint k (.inr (0 : Fin (n + 1)))) + (presentedPrincipalComponent k orderWeight N d) = 1 := by + exact eval_axis_eq_one_of_pureCoefficient_one + (.inr (0 : Fin (n + 1))) + (canonical_orderPrincipalComponent_isHomogeneous n N hd) + (canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd) + +/-- Any checked affine locus contained in the canonical principal-symbol +hypersurface excludes the distinguished pure-momentum axis. -/ +theorem canonical_pureMomentumAxis_not_mem_of_subset_principal_zeroLocus + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {S : Set (PhaseVar (n + 1) → k)} + (hS : S ⊆ MvPolynomial.zeroLocus k + (Ideal.span + ({presentedPrincipalComponent k orderWeight N d} : + Set (SymbolRing k (n + 1))))) : + axisPoint k (.inr (0 : Fin (n + 1))) ∉ S := by + intro haxis + exact false_of_axis_mem_of_subset_principal_zeroLocus + (.inr (0 : Fin (n + 1))) + (canonical_orderPrincipalComponent_isHomogeneous n N hd) + (canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd) + hS haxis + +/-- The reduced canonical order-support zero locus is contained in the +canonical principal-symbol hypersurface. -/ +theorem canonical_reducedOrderSupport_zeroLocus_subset_principal_zeroLocus + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + MvPolynomial.zeroLocus k + (reducedOrderSupportIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) ⊆ + MvPolynomial.zeroLocus k + (Ideal.span + ({presentedPrincipalComponent k orderWeight N d} : + Set (SymbolRing k (n + 1)))) := by + apply MvPolynomial.zeroLocus_anti_mono + apply Ideal.span_le.mpr + intro P hP + rw [Set.mem_singleton_iff.mp hP] + exact orderInitialIdeal_le_reducedOrderSupportIdeal k _ + (canonical_orderPrincipalComponent_mem_initialIdeal k n N hd) + +/-- Exact equation-conormal connector. Under the already isolated +base-relative Poisson hypothesis, membership of the distinguished axis in the +equation-conormal closure is impossible. -/ +theorem false_of_canonical_pureMomentumAxis_mem_equationConormalClosure + [CharZero k] + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + (hJ : IsBaseRelativePoisson + (reducedOrderSupportIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) + (haxis : axisPoint k (.inr (0 : Fin (n + 1))) ∈ + equationConormalClosure + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) : False := by + apply false_of_axis_mem_of_subset_principal_zeroLocus + (.inr (0 : Fin (n + 1))) + (canonical_orderPrincipalComponent_isHomogeneous n N hd) + (canonical_orderPrincipalComponent_pureMomentumCoefficient k n N hd) + (S := equationConormalClosure + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) + · exact (equationConormalClosure_subset_reducedOrderSupport + (canonicalRightIdeal (presentedCoordinate k n) d N) hJ).trans + (canonical_reducedOrderSupport_zeroLocus_subset_principal_zeroLocus + n N hd) + · exact haxis + + +end + +end Stafford38.Geometry.ConormalAxisContradiction diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ConormalPrincipalOpenDensity.lean b/LeanPool/Stafford38/Stafford38/Geometry/ConormalPrincipalOpenDensity.lean new file mode 100644 index 0000000000..93bbbcb4ec --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ConormalPrincipalOpenDensity.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Nullstellensatz +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure + +/-! +# Density of the equation conormal over a principal open + +The first lemma is the algebraic Nullstellensatz/primality core used by the +principal-open density argument. The conormal-specific graph construction is +kept as a separate theorem below, so its hypotheses and its use of the +equation-defined conormal are visible at the call site. +-/ + +namespace Stafford38.Geometry.ConormalPrincipalOpenDensity + +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation + +noncomputable section + +variable {k : Type*} [Field k] [IsAlgClosed k] {n : ℕ} + +theorem mem_of_vanishes_on_principal_open + (I : Ideal (MvPolynomial (Fin n) k)) (hI : I.IsPrime) + {f p : MvPolynomial (Fin n) k} (hf : f ∉ I) + (hp : ∀ y : Fin n → k, y ∈ MvPolynomial.zeroLocus k I → + MvPolynomial.eval y f ≠ 0 → MvPolynomial.eval y p = 0) : + p ∈ I := by + have hfp : f * p ∈ MvPolynomial.vanishingIdeal k + (MvPolynomial.zeroLocus k I) := by + rw [MvPolynomial.mem_vanishingIdeal_iff] + intro y hy + by_cases hfy : MvPolynomial.eval y f = 0 + · simp [hfy] + · rw [map_mul] + change MvPolynomial.eval y f * MvPolynomial.eval y p = 0 + rw [hp y hy hfy] + simp + letI : I.IsPrime := hI + have hfpI : f * p ∈ I := by + rw [MvPolynomial.IsPrime.vanishingIdeal_zeroLocus I] at hfp + exact hfp + rcases hI.mem_or_mem hfpI with hfi | hpi + · exact False.elim (hf hfi) + · exact hpi + +def restrictedEquationConormalLocus + (I : Ideal (MvPolynomial (Fin n) k)) (S : Set (Fin n → k)) : + Set (PhaseVar n → k) := + {q | q ∈ equationConormalLocus I ∧ + (fun i => q (Sum.inl i)) ∈ S} + +theorem restricted_subset_equationConormalLocus + (I : Ideal (MvPolynomial (Fin n) k)) (S : Set (Fin n → k)) : + restrictedEquationConormalLocus I S ⊆ equationConormalLocus I := by + intro q hq + exact hq.1 + +/-- A covector in the equation conormal is the gradient of one equation of +the ideal; finite linear combinations can be absorbed into that equation. -/ +theorem exists_equation_with_differentialAt_eq + (I : Ideal (MvPolynomial (Fin n) k)) (y ξ : Fin n → k) + (hξ : coordinateCovector ξ ∈ affineConormalSpace y I) : + ∃ h ∈ I, ∀ i, differentialAt y h i = ξ i := by + classical + obtain ⟨c, hc⟩ := + coordinate_mem_affineConormalSpace_exists_finsupp y ξ I hξ + let h : MvPolynomial (Fin n) k := + ∑ p ∈ c.support, MvPolynomial.C (c p) * p.1 + refine ⟨h, ?_, fun i => ?_⟩ + · apply Ideal.sum_mem + intro p hp + exact I.mul_mem_left _ p.2 + · rw [hc i] + simp only [h, differentialAt, map_sum, MvPolynomial.pderiv_mul, + MvPolynomial.pderiv_C, zero_mul, zero_add, MvPolynomial.eval_sum, + MvPolynomial.eval_mul, MvPolynomial.eval_C] + +def gradientGraphSubstitution (h : MvPolynomial (Fin n) k) : + SymbolRing k n →+* MvPolynomial (Fin n) k := + MvPolynomial.eval₂Hom MvPolynomial.C + (Sum.elim MvPolynomial.X (fun i => MvPolynomial.pderiv i h)) + +theorem eval_gradientGraphSubstitution + (h : MvPolynomial (Fin n) k) (P : SymbolRing k n) (y : Fin n → k) : + MvPolynomial.eval y (gradientGraphSubstitution h P) = + MvPolynomial.eval (Sum.elim y (differentialAt y h)) P := by + induction P using MvPolynomial.induction_on with + | C a => simp [gradientGraphSubstitution] + | add P Q hP hQ => + simp only [gradientGraphSubstitution] at hP hQ + simp only [gradientGraphSubstitution, map_add, MvPolynomial.eval_add] + rw [hP, hQ] + | mul_X P i hP => + simp only [gradientGraphSubstitution] at hP + rcases i with i | i + · simp only [gradientGraphSubstitution, map_mul, MvPolynomial.eval₂Hom_X', + Sum.elim_inl, MvPolynomial.eval_mul, MvPolynomial.eval_X] + rw [hP] + · simp only [gradientGraphSubstitution, map_mul, MvPolynomial.eval₂Hom_X', + Sum.elim_inr, MvPolynomial.eval_mul] + rw [hP] + simp [differentialAt] + +/-- Restricting the equation conormal to any subset containing the principal +open part of the prime base variety does not change its algebraic closure. -/ +theorem equationConormalClosure_restricted_eq + (I : Ideal (MvPolynomial (Fin n) k)) (hI : I.IsPrime) + (f : MvPolynomial (Fin n) k) (hf : f ∉ I) + (S : Set (Fin n → k)) + (hS : S ⊆ MvPolynomial.zeroLocus k I) + (hopen : ∀ y : Fin n → k, y ∈ MvPolynomial.zeroLocus k I → + MvPolynomial.eval y f ≠ 0 → y ∈ S) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (restrictedEquationConormalLocus I S)) = + equationConormalClosure I := by + apply Set.Subset.antisymm + · exact zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (restrictedEquationConormalLocus I S) + (MvPolynomial.vanishingIdeal k (equationConormalLocus I)) + (fun q hq P hP => hP q hq.1) + · apply zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + intro q qlocus P hP + let y : Fin n → k := fun i => q (.inl i) + let ξ : Fin n → k := fun i => q (.inr i) + obtain ⟨h, hhI, hgrad⟩ := + exists_equation_with_differentialAt_eq I y ξ qlocus.2 + have hrho : gradientGraphSubstitution h P ∈ I := by + apply mem_of_vanishes_on_principal_open I hI hf + intro z hzI hzf + have hzS : z ∈ S := hopen z hzI hzf + have hgraph : Sum.elim z (differentialAt z h) ∈ + restrictedEquationConormalLocus I S := by + refine ⟨⟨hzI, ?_⟩, hzS⟩ + rw [affineConormalSpace_eq_equationCovectorSpan] + apply Submodule.subset_span + exact ⟨⟨h, hhI⟩, rfl⟩ + rw [eval_gradientGraphSubstitution] + exact hP _ hgraph + have hyrho := qlocus.1 _ hrho + rw [eval_gradientGraphSubstitution] at hyrho + change MvPolynomial.eval (Sum.elim y (differentialAt y h)) P = 0 at hyrho + have hgradfun : differentialAt y h = ξ := funext hgrad + have hsplit : Sum.elim y ξ = q := by + funext i + rcases i with i | i <;> rfl + rw [hgradfun, hsplit] at hyrho + exact hyrho + + +end + +end Stafford38.Geometry.ConormalPrincipalOpenDensity diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ConormalScalarExtensionVanishing.lean b/LeanPool/Stafford38/Stafford38/Geometry/ConormalScalarExtensionVanishing.lean new file mode 100644 index 0000000000..9e555f1973 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ConormalScalarExtensionVanishing.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Nullstellensatz +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Scalar extension of equation-conormal vanishing +-/ + +namespace Stafford38.Geometry.ConormalScalarExtensionVanishing + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Characteristic + +noncomputable section + +variable {k K : Type*} [Field k] [IsAlgClosed k] [Field K] [Algebra k K] +variable {n : ℕ} + +def groundGradientSpan (I : Ideal (MvPolynomial (Fin n) k)) + (y : Fin n → K) : Submodule K (Fin n → K) := + Submodule.span K + (Set.range fun h : I => fun i => + MvPolynomial.eval₂ (algebraMap k K) y (MvPolynomial.pderiv i h.1)) + +theorem differential_mem_groundGradientSpan + (I : Ideal (MvPolynomial (Fin n) k)) (y : Fin n → K) + (hy : ∀ h ∈ I, MvPolynomial.eval₂ (algebraMap k K) y h = 0) + (g : MvPolynomial (Fin n) K) + (hg : g ∈ I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) : + (fun i => differentialAt y g i) ∈ groundGradientSpan I y := by + classical + change g ∈ Ideal.span + (scalarPolynomialMap (k := k) (K := K) (Fin n) '' I) at hg + induction hg using Submodule.span_induction with + | mem g hg => + obtain ⟨h, hh, rfl⟩ := hg + apply Submodule.subset_span + refine ⟨⟨h, hh⟩, ?_⟩ + funext i + exact (differentialAt_scalarPolynomialMap y h i).symm + | zero => + change (0 : Fin n → K) ∈ groundGradientSpan I y + exact (groundGradientSpan I y).zero_mem + | add g h _ _ hg hh => + have heq : (fun i => differentialAt y (g + h) i) = + (fun i => differentialAt y g i) + (fun i => differentialAt y h i) := by + funext i + simp [differentialAt] + rw [heq] + exact (groundGradientSpan I y).add_mem hg hh + | smul a g hg ih => + have hgeval : MvPolynomial.eval y g = 0 := by + have hy' : y ∈ MvPolynomial.zeroLocus K + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) := + (mem_zeroLocus_map_iff I y).mpr hy + exact hy' g hg + have heq : (fun i => differentialAt y (a * g) i) = + MvPolynomial.eval y a • (fun i => differentialAt y g i) := by + funext i + simp [differentialAt, MvPolynomial.pderiv_mul, hgeval] + rw [smul_eq_mul, heq] + exact (groundGradientSpan I y).smul_mem _ ih + +theorem conormal_covector_mem_groundGradientSpan + (I : Ideal (MvPolynomial (Fin n) k)) (q : PhaseVar n → K) + (hq : q ∈ equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n)))) : + (fun i => q (.inr i)) ∈ groundGradientSpan I (fun i => q (.inl i)) := by + classical + let y : Fin n → K := fun i => q (.inl i) + let ξ : Fin n → K := fun i => q (.inr i) + have hq' := (mem_equationConormalLocus_map_iff I q).mp hq + obtain ⟨c, hc⟩ := coordinate_mem_affineConormalSpace_exists_finsupp + y ξ _ hq'.2 + have heq : ξ = ∑ g ∈ c.support, c g • (fun i => differentialAt y g.1 i) := by + funext i + simpa [Finset.sum_apply] using (hc i) + change ξ ∈ groundGradientSpan I y + rw [heq] + apply Submodule.sum_mem + intro g hg + exact (groundGradientSpan I y).smul_mem _ + (differential_mem_groundGradientSpan I y hq'.1 g.1 g.2) + +theorem exists_ground_gradient_finsupp + (I : Ideal (MvPolynomial (Fin n) k)) (q : PhaseVar n → K) + (hq : q ∈ equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n)))) : + ∃ c : I →₀ K, ∀ i, + q (.inr i) = ∑ h ∈ c.support, c h * + MvPolynomial.eval₂ (algebraMap k K) (fun j => q (.inl j)) + (MvPolynomial.pderiv i h.1) := by + classical + have hm := conormal_covector_mem_groundGradientSpan I q hq + rw [groundGradientSpan, Finsupp.mem_span_range_iff_exists_finsupp] at hm + obtain ⟨c, hc⟩ := hm + refine ⟨c, fun i => ?_⟩ + have hi := congrFun hc i + simpa [Finsupp.linearCombination_apply, Finsupp.sum, mul_comm] using hi.symm + +def finiteGradientSubstitution {ι : Type*} [Fintype ι] + (h : ι → MvPolynomial (Fin n) k) : + SymbolRing k n →+* MvPolynomial (Fin n ⊕ ι) k := + MvPolynomial.eval₂Hom MvPolynomial.C + (Sum.elim (fun i => MvPolynomial.X (.inl i)) + (fun i => ∑ a : ι, MvPolynomial.X (.inr a) * + MvPolynomial.rename Sum.inl (MvPolynomial.pderiv i (h a)))) + +theorem eval₂_finiteGradientSubstitution {L : Type*} [Field L] [Algebra k L] + {ι : Type*} [Fintype ι] (h : ι → MvPolynomial (Fin n) k) + (P : SymbolRing k n) (z : Fin n ⊕ ι → L) : + MvPolynomial.eval₂ (algebraMap k L) z (finiteGradientSubstitution h P) = + MvPolynomial.eval₂ (algebraMap k L) + (Sum.elim (fun i => z (.inl i)) + (fun i => ∑ a : ι, z (.inr a) * + MvPolynomial.eval₂ (algebraMap k L) (fun j => z (.inl j)) + (MvPolynomial.pderiv i (h a)))) P := by + induction P using MvPolynomial.induction_on with + | C a => simp [finiteGradientSubstitution] + | add P Q hP hQ => + simp only [map_add, MvPolynomial.eval₂_add] + rw [hP, hQ] + | mul_X P i hP => + simp only [map_mul, MvPolynomial.eval₂_mul] + rw [hP] + rcases i with i | i + · simp [finiteGradientSubstitution] + · simp [finiteGradientSubstitution, MvPolynomial.eval₂_rename] + left + congr 1 + +theorem scalarExtension_vanishing + (I : Ideal (MvPolynomial (Fin n) k)) (P : SymbolRing k n) + (hP : ∀ q ∈ equationConormalLocus I, MvPolynomial.eval q P = 0) + (q : PhaseVar n → K) + (hq : q ∈ equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n)))) : + MvPolynomial.eval₂ (algebraMap k K) q P = 0 := by + classical + obtain ⟨c, hc⟩ := exists_ground_gradient_finsupp I q hq + let ι := {h : I // h ∈ c.support} + let equations : ι → MvPolynomial (Fin n) k := fun a => a.1.1 + let ρ := finiteGradientSubstitution equations + let J : Ideal (MvPolynomial (Fin n ⊕ ι) k) := + I.map (MvPolynomial.rename Sum.inl) + have hvan : ρ P ∈ MvPolynomial.vanishingIdeal k + (MvPolynomial.zeroLocus k J) := by + rw [MvPolynomial.mem_vanishingIdeal_iff] + intro z hz + let y : Fin n → k := fun i => z (.inl i) + let ξ : Fin n → k := fun i => ∑ a : ι, z (.inr a) * differentialAt y (equations a) i + have hy : y ∈ MvPolynomial.zeroLocus k I := by + intro f hf + have hm : MvPolynomial.rename Sum.inl f ∈ J := + Ideal.mem_map_of_mem (MvPolynomial.rename Sum.inl) hf + have := hz _ hm + change MvPolynomial.eval₂ (algebraMap k k) z + (MvPolynomial.rename Sum.inl f) = 0 at this + rw [MvPolynomial.eval₂_rename] at this + have he : z ∘ Sum.inl = y := by rfl + rw [he] at this + simpa [MvPolynomial.aeval_def] using this + have hξ : coordinateCovector ξ ∈ affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan] + have heq : coordinateCovector ξ = + ∑ a : ι, z (.inr a) • differentialCovector y (equations a) := by + ext v + simp [ξ, coordinateCovector, differentialCovector, + Finset.sum_mul, Finset.mul_sum] + rw [Finset.sum_comm] + simp [mul_assoc] + rw [heq] + apply Submodule.sum_mem + intro a ha + apply Submodule.smul_mem + apply Submodule.subset_span + exact ⟨a.1, rfl⟩ + have heval := eval₂_finiteGradientSubstitution equations P z + have hzero := hP (Sum.elim y ξ) ⟨hy, hξ⟩ + simpa [ρ, y, ξ, MvPolynomial.aeval_def] using heval.trans hzero + letI : Finite ι := Finite.of_fintype ι + have hrad : ρ P ∈ J.radical := by + rw [← MvPolynomial.vanishingIdeal_zeroLocus_eq_radical (K := k) J] + exact hvan + obtain ⟨m, hm⟩ := (Ideal.mem_radical_iff.mp hrad) + let z : Fin n ⊕ ι → K := Sum.elim (fun i => q (.inl i)) (fun a => c a.1) + have hzJ : z ∈ MvPolynomial.zeroLocus K J := by + change z ∈ MvPolynomial.zeroLocus K + (I.map (MvPolynomial.rename Sum.inl)) + rw [Ideal.map, MvPolynomial.zeroLocus_span] + rintro _ ⟨f, hf, rfl⟩ + change MvPolynomial.eval₂ (algebraMap k K) z + (MvPolynomial.rename Sum.inl f) = 0 + rw [MvPolynomial.eval₂_rename] + have he : z ∘ Sum.inl = fun i => q (.inl i) := by + funext i + rfl + rw [he] + exact ((mem_equationConormalLocus_map_iff I q).mp hq).1 f hf + have hpw : (MvPolynomial.eval₂ (algebraMap k K) z (ρ P)) ^ m = 0 := by + simpa only [MvPolynomial.aeval_def, map_pow] using hzJ _ hm + have hrho : MvPolynomial.eval₂ (algebraMap k K) z (ρ P) = 0 := + eq_zero_of_pow_eq_zero hpw + rw [eval₂_finiteGradientSubstitution equations P z] at hrho + have hpoint : + Sum.elim (fun i => z (.inl i)) + (fun i => ∑ a : ι, z (.inr a) * + MvPolynomial.eval₂ (algebraMap k K) (fun j => z (.inl j)) + (MvPolynomial.pderiv i (equations a))) = q := by + funext v + rcases v with i | i + · rfl + · have hi := (hc i).symm + rw [← Finset.sum_attach] at hi + simpa [z, equations, ι, Finsupp.sum] using hi + rw [hpoint] at hrho + exact hrho + + +end +end Stafford38.Geometry.ConormalScalarExtensionVanishing diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ConstantCoordinateConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/ConstantCoordinateConormal.lean new file mode 100644 index 0000000000..5e2ee29de7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ConstantCoordinateConormal.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Constant-coordinate conormal directions + +The boundary-divisor argument is needed only when the distinguished affine +coordinate is nonconstant on the relevant base component. If +`X_i - c` already belongs to the reduced base ideal, its differential is the +pure `i`-th coordinate covector at every base point. The desired conormal +axis is then present at a constant point, with no projective boundary or +completion. +-/ + +namespace Stafford38.Geometry.ConstantCoordinateConormal + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The differential of `X_i - c` is the pure `i`-th coordinate covector. -/ +theorem differentialCovector_coordinate_sub_constant + (y : Fin m → k) (i : Fin m) (c : k) : + differentialCovector y (MvPolynomial.X i - MvPolynomial.C c) = + coordinateCovector (fun j ↦ if j = i then 1 else 0) := by + ext v + simp [differentialCovector, coordinateCovector, differentialAt, + Pi.single_apply] + +/-- A constant-coordinate equation places the corresponding pure axis in the +equation-defined affine conormal space. -/ +theorem pureCoordinate_mem_affineConormalSpace_of_sub_constant_mem + (I : Ideal (MvPolynomial (Fin m) k)) + (y : Fin m → k) (i : Fin m) (c : k) + (hcoordinate : MvPolynomial.X i - MvPolynomial.C c ∈ I) : + coordinateCovector (fun j ↦ if j = i then 1 else 0) ∈ + affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan] + rw [← differentialCovector_coordinate_sub_constant y i c] + apply Submodule.subset_span + exact ⟨⟨MvPolynomial.X i - MvPolynomial.C c, hcoordinate⟩, rfl⟩ + +/-- The constant-coordinate branch produces an actual equation-conormal +point over every common zero of the base ideal. -/ +theorem constantCoordinate_phasePoint_mem_equationConormalLocus + (I : Ideal (MvPolynomial (Fin m) k)) + (y : Fin m → k) + (hy : ∀ f ∈ I, MvPolynomial.eval y f = 0) + (i : Fin m) (c : k) + (hcoordinate : MvPolynomial.X i - MvPolynomial.C c ∈ I) : + Sum.elim y (fun j ↦ if j = i then 1 else 0) ∈ + equationConormalLocus I := by + refine ⟨?_, ?_⟩ + · intro f hf + exact hy f hf + · exact pureCoordinate_mem_affineConormalSpace_of_sub_constant_mem + I y i c hcoordinate + +/-- The same constant-coordinate branch gives the exact Laurent-series point +used by the terminal asymptotic consumer. All coordinates are constant +series; no boundary valuation is involved. -/ +theorem exists_laurentConormalAxis_of_coordinate_sub_constant_mem + (I : Ideal (MvPolynomial (Fin m) k)) + (y : Fin m → k) + (hy : ∀ f ∈ I, MvPolynomial.eval y f = 0) + (i : Fin m) (c : k) + (hcoordinate : MvPolynomial.X i - MvPolynomial.C c ∈ I) : + ∃ (yL : Fin m → LaurentSeries k) + (xi : Fin m → PowerSeries k), + Sum.elim yL + (fun j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi j)) ∈ + equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m))) ∧ + residueColumn xi = (fun j ↦ if j = i then 1 else 0) := by + let yL : Fin m → LaurentSeries k := fun j ↦ algebraMap k (LaurentSeries k) (y j) + let xi : Fin m → PowerSeries k := fun j ↦ + PowerSeries.C (if j = i then 1 else 0) + let IL := I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) + have hyL : ∀ f ∈ IL, MvPolynomial.eval yL f = 0 := by + rw [show (∀ f ∈ IL, MvPolynomial.eval yL f = 0) ↔ + yL ∈ MvPolynomial.zeroLocus (LaurentSeries k) IL by rfl] + rw [mem_zeroLocus_map_iff] + intro f hf + change MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + ((algebraMap k (LaurentSeries k)) ∘ y) f = 0 + rw [← MvPolynomial.eval₂_comp, hy f hf, map_zero] + have hcoordinateL : + MvPolynomial.X i - + MvPolynomial.C (algebraMap k (LaurentSeries k) c) ∈ IL := by + have hmapped := Ideal.mem_map_of_mem + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) + hcoordinate + change (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) + (MvPolynomial.X i - MvPolynomial.C c) ∈ IL at hmapped + rw [(scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)).map_sub] at hmapped + simpa [scalarPolynomialMap] using hmapped + have hphase := constantCoordinate_phasePoint_mem_equationConormalLocus + IL yL hyL i (algebraMap k (LaurentSeries k) c) hcoordinateL + refine ⟨yL, xi, ?_, ?_⟩ + · convert hphase using 1 + funext q + rcases q with j | j + · rfl + · simp [xi] + · funext j + simp [xi, residueColumn] + + +end + +end Stafford38.Geometry.ConstantCoordinateConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ContinuousPowerSeriesTangentFrame.lean b/LeanPool/Stafford38/Stafford38/Geometry/ContinuousPowerSeriesTangentFrame.lean new file mode 100644 index 0000000000..017a5b11f5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ContinuousPowerSeriesTangentFrame.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.PowerSeries.Derivative +import Mathlib.RingTheory.PowerSeries.PiTopology +import LeanPool.Stafford38.Stafford38.Geometry.FixedWitnessTangentSqueeze +import LeanPool.Stafford38.Stafford38.Geometry.SeparableResidueDerivationExtension + +/-! +# Continuous derivation frames on a supplied power-series chart + +Assume that the completed boundary DVR has already been identified with +`K[[t]]`. This file constructs the two kinds of derivations used on that +chart: + +* the uniformizer derivation `d/dt`; +* the coefficientwise extension of every `k`-derivation of `K`. + +With the product topology on `K[[t]]` and the discrete topology on `K`, both +constructions are continuous. A finite family is indexed by `Option κ`, with +`none` denoting `d/dt` and `some j` denoting the `j`th coefficient derivation. +Taking constant coefficients after applying the frame to the chart +coordinates gives the finite family of affine tangent vectors consumed by +`FixedWitnessTangentSqueeze`. + +The first missing bridge after this file is the chart-to-component tangency +statement: the supplied completed-DVR chart must prove that every residue +frame vector annihilates the differential of every equation of the affine +component. After that, the remaining inputs to the squeeze are independence +of the residue vectors and the tangent-dimension bound. This file does not +construct the residue-field section or the `K[[t]]` chart. +-/ + +namespace Stafford38.Geometry.ContinuousPowerSeriesTangentFrame + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.FixedWitnessTangentSqueeze +open Stafford38.Geometry.SeparableResidueDerivationExtension + +open scoped PowerSeries.WithPiTopology + +noncomputable section + +universe u v + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-- The `k`-linear coefficientwise action underlying the extended +derivation. -/ +noncomputable def coefficientwiseLinearMap (D : Derivation k K K) : + PowerSeries K →ₗ[k] PowerSeries K where + toFun f := PowerSeries.mk fun n ↦ D (PowerSeries.coeff n f) + map_add' f g := by + ext n + simp + map_smul' a f := by + ext n + simp + +@[simp] +theorem coeff_coefficientwiseLinearMap (D : Derivation k K K) + (f : PowerSeries K) (n : ℕ) : + PowerSeries.coeff n (coefficientwiseLinearMap D f) = + D (PowerSeries.coeff n f) := by + change PowerSeries.coeff n + (PowerSeries.mk fun m ↦ D (PowerSeries.coeff m f)) = _ + rw [PowerSeries.coeff_mk] + +/-- Apply a derivation to every coefficient of a formal power series. -/ +noncomputable def coefficientwiseDerivation (D : Derivation k K K) : + Derivation k (PowerSeries K) (PowerSeries K) where + toLinearMap := coefficientwiseLinearMap D + map_one_eq_zero' := by + ext n + by_cases hn : n = 0 <;> + simp [hn, D.map_one_eq_zero] + leibniz' f g := by + ext n + simp only [smul_eq_mul, coeff_coefficientwiseLinearMap] + rw [PowerSeries.coeff_mul, map_add, + PowerSeries.coeff_mul, PowerSeries.coeff_mul] + rw [map_sum] + simp_rw [D.leibniz] + rw [Finset.sum_add_distrib] + simp only [coeff_coefficientwiseLinearMap, smul_eq_mul] + congr 1 + simpa only [Prod.fst_swap, Prod.snd_swap] using + (Finset.Nat.sum_antidiagonal_swap (n := n) + (f := fun p ↦ PowerSeries.coeff p.1 g * + D (PowerSeries.coeff p.2 f))) + +@[simp] +theorem coeff_coefficientwiseDerivation (D : Derivation k K K) + (f : PowerSeries K) (n : ℕ) : + PowerSeries.coeff n (coefficientwiseDerivation D f) = + D (PowerSeries.coeff n f) := by + exact coeff_coefficientwiseLinearMap D f n + +@[simp] +theorem coefficientwiseDerivation_C (D : Derivation k K K) (a : K) : + coefficientwiseDerivation D (PowerSeries.C a) = + PowerSeries.C (D a) := by + ext n + cases n <;> simp + +@[simp] +theorem coefficientwiseDerivation_X (D : Derivation k K K) : + coefficientwiseDerivation D (PowerSeries.X : PowerSeries K) = 0 := by + ext n + by_cases hn : n = 1 <;> + simp [PowerSeries.coeff_X, hn, D.map_one_eq_zero] + +/-- Coefficientwise derivations are continuous for the coefficientwise +topology when the coefficient field is discrete. -/ +theorem continuous_coefficientwiseDerivation + [TopologicalSpace K] [DiscreteTopology K] + (D : Derivation k K K) : + Continuous (coefficientwiseDerivation D) := by + refine continuous_pi_iff.mpr fun d ↦ ?_ + exact (continuous_of_discreteTopology : Continuous D).comp + (PowerSeries.WithPiTopology.continuous_coeff K (d ())) + +/-- The uniformizer derivation, regarded as a `k`-derivation by restriction +along `k → K → K[[t]]`. -/ +noncomputable def uniformizerDerivation : + Derivation k (PowerSeries K) (PowerSeries K) := + (PowerSeries.derivative K).restrictScalars k + +@[simp] +theorem uniformizerDerivation_C (a : K) : + uniformizerDerivation (k := k) (K := K) (PowerSeries.C a) = 0 := by + simp [uniformizerDerivation] + +@[simp] +theorem uniformizerDerivation_X : + uniformizerDerivation (k := k) (K := K) + (PowerSeries.X : PowerSeries K) = 1 := by + simp [uniformizerDerivation] + +theorem coeff_uniformizerDerivation (f : PowerSeries K) (n : ℕ) : + PowerSeries.coeff n + (uniformizerDerivation (k := k) (K := K) f) = + PowerSeries.coeff (n + 1) f * (n + 1) := by + exact PowerSeries.coeff_derivative f n + +/-- Formal differentiation is continuous in the coefficientwise topology. -/ +theorem continuous_uniformizerDerivation + [TopologicalSpace K] [DiscreteTopology K] : + Continuous (uniformizerDerivation (k := k) (K := K)) := by + refine continuous_pi_iff.mpr fun d ↦ ?_ + obtain ⟨n, rfl⟩ : ∃ n, d = Finsupp.single () n := + ⟨d default, Finsupp.unique_single d⟩ + show Continuous fun a : PowerSeries K ↦ + PowerSeries.coeff n (uniformizerDerivation (k := k) (K := K) a) + rw [funext fun f ↦ coeff_uniformizerDerivation (k := k) (K := K) f n] + exact (continuous_of_discreteTopology : + Continuous (fun a : K ↦ a * (n + 1))).comp + (PowerSeries.WithPiTopology.continuous_coeff K (n + 1)) + +/-- Index type for the uniformizer direction together with a finite family of +coefficient directions. -/ +abbrev FrameIndex (κ : Type v) := Option κ + +/-- The derivation frame on `K[[t]]`: `none` is `d/dt`, while `some j` acts +coefficientwise by `D j`. -/ +noncomputable def powerSeriesDerivationFrame {κ : Type v} + (D : κ → Derivation k K K) : + FrameIndex κ → Derivation k (PowerSeries K) (PowerSeries K) + | none => uniformizerDerivation + | some j => coefficientwiseDerivation (D j) + +/-- Every member of the finite chart frame is continuous. -/ +theorem continuous_powerSeriesDerivationFrame + [TopologicalSpace K] [DiscreteTopology K] + {κ : Type v} (D : κ → Derivation k K K) (j : FrameIndex κ) : + Continuous (powerSeriesDerivationFrame D j) := by + cases j with + | none => exact continuous_uniformizerDerivation + | some j => exact continuous_coefficientwiseDerivation (D j) + +/-- Evaluate a chart derivation on each affine coordinate and specialize at +the closed point. -/ +def residueFrameVector {n : ℕ} {κ : Type v} + (q : Fin n → PowerSeries K) (D : κ → Derivation k K K) + (j : FrameIndex κ) : AffineTangentVector K n := + fun i ↦ PowerSeries.constantCoeff (powerSeriesDerivationFrame D j (q i)) + +@[simp] +theorem residueFrameVector_uniformizer {n : ℕ} {κ : Type v} + (q : Fin n → PowerSeries K) (D : κ → Derivation k K K) (i : Fin n) : + residueFrameVector q D none i = PowerSeries.coeff 1 (q i) := by + rw [residueFrameVector, powerSeriesDerivationFrame, + ← PowerSeries.coeff_zero_eq_constantCoeff] + simpa using coeff_uniformizerDerivation (k := k) (K := K) (q i) 0 + +@[simp] +theorem residueFrameVector_coefficient {n : ℕ} {κ : Type v} + (q : Fin n → PowerSeries K) (D : κ → Derivation k K K) + (j : κ) (i : Fin n) : + residueFrameVector q D (some j) i = + D j (PowerSeries.constantCoeff (q i)) := by + rw [residueFrameVector, powerSeriesDerivationFrame, + ← PowerSeries.coeff_zero_eq_constantCoeff] + exact coeff_coefficientwiseDerivation (D j) (q i) 0 + +/-- Exact finite-dimensional handoff to `FixedWitnessTangentSqueeze`. + +The three hypotheses are precisely the geometric obligations left to the +supplied completed-DVR chart: tangency of every specialized derivation, +independence of the resulting residue vectors, and the tangent-dimension +bound. -/ +theorem tangent_eq_span_residueFrame + {n : ℕ} {κ : Type v} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) K)) + (q : Fin n → PowerSeries K) + (D : κ → Derivation k K K) + (hb : ∀ j, residueFrameVector q D j ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I) + (hindependent : LinearIndependent K (residueFrameVector q D)) + (hfinrank : Module.finrank K + (zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I) ≤ + Fintype.card (FrameIndex κ)) : + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I = + Submodule.span K (Set.range (residueFrameVector q D)) := by + exact fixedWitnessTangentSqueeze I _ _ hb hindependent hfinrank + +/-- Reverse-inclusion form used by the conormal annihilator consumer. -/ +theorem tangent_le_span_residueFrame + {n : ℕ} {κ : Type v} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) K)) + (q : Fin n → PowerSeries K) + (D : κ → Derivation k K K) + (hb : ∀ j, residueFrameVector q D j ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I) + (hindependent : LinearIndependent K (residueFrameVector q D)) + (hfinrank : Module.finrank K + (zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I) ≤ + Fintype.card (FrameIndex κ)) : + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I ≤ + Submodule.span K (Set.range (residueFrameVector q D)) := by + rw [tangent_eq_span_residueFrame I q D hb hindependent hfinrank] + +/-- Extend a finite family of coefficient-field derivations through a +separable residue extension and then coefficientwise to the supplied +`K[[t]]` chart. -/ +noncomputable def separablePowerSeriesDerivationFrame + {E : Type u} [Field E] [Algebra k E] [Algebra E K] + [IsScalarTower k E K] [Algebra.IsSeparable E K] + {κ : Type v} (D : κ → Derivation k E E) : + FrameIndex κ → Derivation k (PowerSeries K) (PowerSeries K) := + powerSeriesDerivationFrame + (fun j ↦ extendCoefficientDerivation k E K (D j)) + +@[simp] +theorem separablePowerSeriesDerivationFrame_none + {E : Type u} [Field E] [Algebra k E] [Algebra E K] + [IsScalarTower k E K] [Algebra.IsSeparable E K] + {κ : Type v} (D : κ → Derivation k E E) : + separablePowerSeriesDerivationFrame (K := K) D none = + uniformizerDerivation := by + rfl + +@[simp] +theorem separablePowerSeriesDerivationFrame_some_C + {E : Type u} [Field E] [Algebra k E] [Algebra E K] + [IsScalarTower k E K] [Algebra.IsSeparable E K] + {κ : Type v} (D : κ → Derivation k E E) (j : κ) (a : E) : + separablePowerSeriesDerivationFrame (K := K) D (some j) + (PowerSeries.C (algebraMap E K a)) = + PowerSeries.C (algebraMap E K (D j a)) := by + rw [separablePowerSeriesDerivationFrame, powerSeriesDerivationFrame, + coefficientwiseDerivation_C] + congr 1 + exact Derivation.congr_fun + (extendCoefficientDerivation_compAlgebraMap k E K (D j)) a + +/-- Continuity of the complete frame obtained from the separable residue +tower. -/ +theorem continuous_separablePowerSeriesDerivationFrame + [TopologicalSpace K] [DiscreteTopology K] + {E : Type u} [Field E] [Algebra k E] [Algebra E K] + [IsScalarTower k E K] [Algebra.IsSeparable E K] + {κ : Type v} (D : κ → Derivation k E E) (j : FrameIndex κ) : + Continuous (separablePowerSeriesDerivationFrame (K := K) D j) := by + exact continuous_powerSeriesDerivationFrame _ j + + +end + +end Stafford38.Geometry.ContinuousPowerSeriesTangentFrame diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorTangentLattice.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorTangentLattice.lean new file mode 100644 index 0000000000..8b1a394ddf --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorTangentLattice.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# The divisor-tangent lattice lemma + +Let `V` be a local ring inside a field `F`, `t` an element of its maximal +ideal, and `d` a derivation of `F` with values in an `F`-vector space `Ω`. +Suppose the homogeneous coordinates `Q₀, Q₁, Q j` lie in `V` with + +```text +Q₀ = t^a * u, Q₁ = t^(a+e) * w, Q j₀ = 1, a, e ≥ 1, u a unit. +``` + +The affine coordinates are `x j = Q j / Q₀` and `x₁ = Q₁ / Q₀`. Let `W` be +a finitely generated `V`-lattice in `Ω` containing `d t`, `d u`, `d w` and +the `d (Q j)`; in the geometric application `W` is the image of `Ω_{V/k}`. +The *visibility* hypothesis asks that `W` is spanned modulo `t W` by `d t` +and the `d (Q j)`. Under it, +the differential `d x₁` is a combination of the `d (x j)` with coefficients +in the maximal ideal of `V`: + +```text +d x₁ = ∑ j, c j • d (x j), c j ∈ m_V. +``` + +This is the algebraic content of the asymptotic-conormal lemma: after +completing `V` the covector `e₁ - ∑ c j e_j` has residue exactly the first +axis, and it annihilates every tangent vector at the generic point because +the identity holds in the module of differentials. The proof is Nakayama's +lemma applied to the lattice spanned by the scaled differentials +`t^(a+1) u^2 • d (x j)`. + +No geometry enters here: the visibility hypothesis is an explicit statement +about the derivation restricted to `V`, and producing a place that satisfies +it is the remaining geometric input of lane C. +-/ + +namespace Stafford38.Geometry.DivisorTangentLattice + +open IsLocalRing + +noncomputable section + +universe u v w x y + +variable {k : Type u} {V : Type v} {F : Type w} {Ω : Type x} +variable [CommRing k] [CommRing V] [IsLocalRing V] [Field F] +variable [Algebra k F] [Algebra V F] +variable [AddCommGroup Ω] [Module k Ω] [Module F Ω] [Module V Ω] +variable [IsScalarTower V F Ω] + +variable (d : Derivation k F Ω) +variable {ι : Type y} [Fintype ι] + + +/-- The `V`-lattice spanned by `d t` and the differentials of the +homogeneous coordinates. -/ +def coordinateFrame (t : V) (Q : ι → V) : Submodule V Ω := + Submodule.span V {d (algebraMap V F t)} ⊔ + Submodule.span V (Set.range fun j ↦ d (algebraMap V F (Q j))) + +theorem dQ_mem_coordinateFrame (t : V) (Q : ι → V) (j : ι) : + d (algebraMap V F (Q j)) ∈ coordinateFrame d t Q := + Submodule.mem_sup_right (Submodule.subset_span ⟨j, rfl⟩) + +/-- Normalized divisor-frame data for the lattice lemma. All coordinates +are elements of `V`. The lattice `W` is any finitely generated `V`-submodule +containing the differentials of `t`, `u`, `w` and the `Q j`; in the geometric +application it is the image of `Ω_{V/k}`. The visibility field is the only +non-algebraic hypothesis: modulo `t`, the lattice `W` is spanned by `d t` and +the `d (Q j)`. -/ +structure VisibleDivisorFrame (d : Derivation k F Ω) (ι : Type y) [Fintype ι] where + Q₀ : V + Q₁ : V + t : V + u : V + w : V + Q : ι → V + a : ℕ + e : ℕ + j₀ : ι + W : Submodule V Ω + t_mem : t ∈ maximalIdeal V + t_ne : t ≠ 0 + u_unit : IsUnit u + a_unit : IsUnit (a : V) + one_le_a : 1 ≤ a + one_le_e : 1 ≤ e + Q₀_eq : Q₀ = t ^ a * u + Q₁_eq : Q₁ = t ^ (a + e) * w + Q_j₀ : Q j₀ = 1 + W_fg : W.FG + dt_mem : d (algebraMap V F t) ∈ W + du_mem : d (algebraMap V F u) ∈ W + dw_mem : d (algebraMap V F w) ∈ W + dQ_mem : ∀ j, d (algebraMap V F (Q j)) ∈ W + visible : W ≤ coordinateFrame d t Q ⊔ Ideal.span {t} • W + +namespace VisibleDivisorFrame + +variable {d} +variable (D : VisibleDivisorFrame (V := V) d ι) + +/-- The scaled differential of the affine coordinate with numerator `P`. -/ +def scaledDifferential (P : V) : Ω := + (algebraMap V F D.t ^ (D.a + 1) * algebraMap V F D.u ^ 2) • + d (algebraMap V F P / algebraMap V F D.Q₀) + +theorem algebraMap_t_ne_zero (hinj : Function.Injective (algebraMap V F)) : + algebraMap V F D.t ≠ 0 := + (map_ne_zero_iff _ hinj).2 D.t_ne + +theorem algebraMap_u_ne_zero : algebraMap V F D.u ≠ 0 := + (D.u_unit.map (algebraMap V F)).ne_zero + +theorem scale_ne_zero (hinj : Function.Injective (algebraMap V F)) : + algebraMap V F D.t ^ (D.a + 1) * algebraMap V F D.u ^ 2 ≠ 0 := + mul_ne_zero (pow_ne_zero _ (D.algebraMap_t_ne_zero hinj)) + (pow_ne_zero _ D.algebraMap_u_ne_zero) + +/-- The scaled affine differential in terms of differentials of elements of +`V`. This is the only place where the quotient rule is used. -/ +theorem scaledDifferential_eq (hinj : Function.Injective (algebraMap V F)) + (P : V) : + D.scaledDifferential P = + (D.u * D.t) • d (algebraMap V F P) - + ((D.a : V) * P * D.u) • d (algebraMap V F D.t) - + (D.t * P) • d (algebraMap V F D.u) := by + obtain ⟨a', ha'⟩ := Nat.exists_eq_add_of_le' D.one_le_a + have hT := D.algebraMap_t_ne_zero hinj + have hU := D.algebraMap_u_ne_zero + unfold scaledDifferential + rw [Derivation.leibniz_div, D.Q₀_eq, map_mul, map_pow, Derivation.leibniz, + Derivation.leibniz_pow] + simp only [← algebraMap_smul (R := V) (A := F) (M := Ω), map_mul, map_natCast, + ha', Nat.add_sub_cancel, ← Nat.cast_smul_eq_nsmul F] + simp only [smul_sub, smul_add, smul_smul] + rw [sub_sub] + congr 1 + · congr 1 + field_simp + ring + · rw [add_comm] + congr 1 + · congr 1 + field_simp + ring + · congr 1 + field_simp + ring + +/-- The lattice spanned by the scaled affine differentials of the +coordinates `Q j`. -/ +def scaledLattice : Submodule V Ω := + Submodule.span V (Set.range fun j ↦ D.scaledDifferential (D.Q j)) + +theorem scaledDifferential_mem_scaledLattice (j : ι) : + D.scaledDifferential (D.Q j) ∈ D.scaledLattice := + Submodule.subset_span ⟨j, rfl⟩ + +theorem scaledDifferential_j₀ (hinj : Function.Injective (algebraMap V F)) : + D.scaledDifferential (D.Q D.j₀) = + -(((D.a : V) * D.u) • d (algebraMap V F D.t)) - + D.t • d (algebraMap V F D.u) := by + rw [D.scaledDifferential_eq hinj, D.Q_j₀, map_one, Derivation.map_one_eq_zero, + smul_zero, zero_sub, mul_one, mul_one] + +/-- Step (i): `t • d (Q j)` lies in the scaled lattice. -/ +theorem t_smul_dQ_mem_scaledLattice (hinj : Function.Injective (algebraMap V F)) + (j : ι) : + D.t • d (algebraMap V F (D.Q j)) ∈ D.scaledLattice := by + have hid : (D.u * D.t) • d (algebraMap V F (D.Q j)) = + D.scaledDifferential (D.Q j) - D.Q j • D.scaledDifferential (D.Q D.j₀) := by + rw [D.scaledDifferential_eq hinj, D.scaledDifferential_j₀ hinj] + module + have hmem : (D.u * D.t) • d (algebraMap V F (D.Q j)) ∈ D.scaledLattice := by + rw [hid] + exact Submodule.sub_mem _ (D.scaledDifferential_mem_scaledLattice j) + (Submodule.smul_mem _ _ (D.scaledDifferential_mem_scaledLattice D.j₀)) + have hinv : D.t • d (algebraMap V F (D.Q j)) = + (↑D.u_unit.unit⁻¹ : V) • ((D.u * D.t) • d (algebraMap V F (D.Q j))) := by + rw [smul_smul, ← mul_assoc, Units.inv_mul_of_eq D.u_unit.unit_spec, one_mul] + rw [hinv] + exact Submodule.smul_mem _ _ hmem + +/-- The ideal generated by the uniformizer. -/ +def parameterIdeal : Ideal V := Ideal.span {D.t} + +theorem t_mem_parameterIdeal : D.t ∈ D.parameterIdeal := + Ideal.mem_span_singleton_self _ + +theorem parameterIdeal_le_jacobson : D.parameterIdeal ≤ (⊥ : Ideal V).jacobson := + (Ideal.span_le.2 (Set.singleton_subset_iff.2 D.t_mem)).trans + (maximalIdeal_le_jacobson _) + +theorem parameterIdeal_fg : D.parameterIdeal.FG := + Submodule.fg_span_singleton _ + +/-- Step (ii): `t • d t` lies in the scaled lattice up to `t²` times the +lattice `W`. -/ +theorem t_smul_dt_mem (hinj : Function.Injective (algebraMap V F)) : + D.t • d (algebraMap V F D.t) ∈ + D.scaledLattice ⊔ + D.parameterIdeal • (D.parameterIdeal • D.W) := by + have hid : ((D.a : V) * D.u) • (D.t • d (algebraMap V F D.t)) = + -(D.t • D.scaledDifferential (D.Q D.j₀)) - + D.t • (D.t • d (algebraMap V F D.u)) := by + rw [D.scaledDifferential_j₀ hinj] + module + have hmem : ((D.a : V) * D.u) • (D.t • d (algebraMap V F D.t)) ∈ + D.scaledLattice ⊔ + D.parameterIdeal • (D.parameterIdeal • D.W) := by + rw [hid] + refine Submodule.sub_mem _ (Submodule.neg_mem _ ?_) ?_ + · exact Submodule.mem_sup_left + (Submodule.smul_mem _ _ (D.scaledDifferential_mem_scaledLattice D.j₀)) + · exact Submodule.mem_sup_right + (Submodule.smul_mem_smul D.t_mem_parameterIdeal + (Submodule.smul_mem_smul D.t_mem_parameterIdeal + D.du_mem)) + have hunit : IsUnit ((D.a : V) * D.u) := D.a_unit.mul D.u_unit + have hinv : D.t • d (algebraMap V F D.t) = + (↑hunit.unit⁻¹ : V) • (((D.a : V) * D.u) • (D.t • d (algebraMap V F D.t))) := by + rw [smul_smul, Units.inv_mul_of_eq hunit.unit_spec, one_smul] + rw [hinv] + exact Submodule.smul_mem _ _ hmem + +/-- Step (iii): `t` times the unit frame is contained in the scaled lattice +up to `t²` times the unit frame. -/ +theorem parameterIdeal_smul_W_le (hinj : Function.Injective (algebraMap V F)) : + D.parameterIdeal • D.W ≤ + D.scaledLattice ⊔ D.parameterIdeal • (D.parameterIdeal • D.W) := by + set L := D.scaledLattice + set I := D.parameterIdeal + set R := L ⊔ I • (I • D.W) + -- The elements whose `t`-multiple lies in `R`. + let M : Submodule V Ω := Submodule.comap (LinearMap.lsmul V Ω D.t) R + have hM : ∀ ω ∈ M, D.t • ω ∈ R := fun ω hω ↦ hω + have hcoord : coordinateFrame d D.t D.Q ≤ M := by + refine sup_le ?_ ?_ + · rw [Submodule.span_le, Set.singleton_subset_iff] + exact D.t_smul_dt_mem hinj + · rw [Submodule.span_le] + rintro _ ⟨j, rfl⟩ + exact Submodule.mem_sup_left (D.t_smul_dQ_mem_scaledLattice hinj j) + -- `t` times a visible element lies in `R`. + have hW : D.W ≤ M := by + intro ω hω + obtain ⟨ω₁, hω₁, ω₂, hω₂, rfl⟩ := Submodule.mem_sup.1 (D.visible hω) + show D.t • (ω₁ + ω₂) ∈ R + rw [smul_add] + refine Submodule.add_mem _ (hM ω₁ (hcoord hω₁)) ?_ + exact Submodule.mem_sup_right (Submodule.smul_mem_smul D.t_mem_parameterIdeal hω₂) + refine Submodule.smul_le.2 ?_ + intro r hr ω hω + obtain ⟨s, rfl⟩ := Ideal.mem_span_singleton.1 hr + rw [mul_comm, mul_smul] + exact Submodule.smul_mem _ _ (hM ω (hW hω)) + +/-- Nakayama: `t` times the lattice `W` lies in the scaled lattice. -/ +theorem parameterIdeal_smul_W_le_scaledLattice + (hinj : Function.Injective (algebraMap V F)) : + D.parameterIdeal • D.W ≤ D.scaledLattice := + Submodule.le_of_le_smul_of_le_jacobson_bot + (Submodule.FG.smul D.parameterIdeal_fg D.W_fg) + D.parameterIdeal_le_jacobson + (D.parameterIdeal_smul_W_le hinj) + +/-- Step (iv): the scaled differential of the selected coordinate `Q₁` +is `t^(a+e-1)` times an element of `t` times the lattice `W`. -/ +theorem scaledDifferential_Q₁_eq (hinj : Function.Injective (algebraMap V F)) : + ∃ ω ∈ D.parameterIdeal • D.W, + D.scaledDifferential D.Q₁ = D.t ^ (D.a + D.e - 1) • ω := by + set W := D.W + obtain ⟨a', ha'⟩ := Nat.exists_eq_add_of_le' D.one_le_a + obtain ⟨e', he'⟩ := Nat.exists_eq_add_of_le' D.one_le_e + -- The unscaled combination inside the unit frame. + let ω₀ : Ω := (D.u * D.t) • d (algebraMap V F D.w) + + ((D.e : V) * D.u * D.w) • d (algebraMap V F D.t) - + (D.t * D.w) • d (algebraMap V F D.u) + have hω₀ : ω₀ ∈ D.W := by + refine Submodule.sub_mem _ (Submodule.add_mem _ ?_ ?_) ?_ + · exact Submodule.smul_mem _ _ D.dw_mem + · exact Submodule.smul_mem _ _ D.dt_mem + · exact Submodule.smul_mem _ _ D.du_mem + refine ⟨D.t • ω₀, Submodule.smul_mem_smul D.t_mem_parameterIdeal hω₀, ?_⟩ + have hexp' : D.a + D.e - 1 = a' + e' + 1 := by omega + rw [hexp', D.scaledDifferential_eq hinj, D.Q₁_eq, map_mul, map_pow, Derivation.leibniz, + Derivation.leibniz_pow] + have hexp : a' + 1 + (e' + 1) - 1 = a' + e' + 1 := by omega + simp only [ω₀, ha', he', ← Nat.cast_smul_eq_nsmul F, ← map_natCast (algebraMap V F), + ← map_pow, algebraMap_smul, hexp] + push_cast + module + +/-- The divisor-tangent lattice lemma. The differential of the selected +affine coordinate is a combination of the other affine differentials with +coefficients divisible by `t^(a+e-1)`; in particular the coefficients lie in +the maximal ideal of `V`. -/ +theorem exists_coefficients (hinj : Function.Injective (algebraMap V F)) : + ∃ b : ι → V, + d (algebraMap V F D.Q₁ / algebraMap V F D.Q₀) = + ∑ j, (D.t ^ (D.a + D.e - 1) * b j) • + d (algebraMap V F (D.Q j) / algebraMap V F D.Q₀) := by + classical + obtain ⟨ω, hω, hℓ⟩ := D.scaledDifferential_Q₁_eq hinj + have hωL : ω ∈ D.scaledLattice := + D.parameterIdeal_smul_W_le_scaledLattice hinj hω + obtain ⟨b, hb⟩ := (Submodule.mem_span_range_iff_exists_fun V).1 hωL + refine ⟨b, ?_⟩ + have hscale := D.scale_ne_zero hinj + have hleft : (algebraMap V F D.t ^ (D.a + 1) * algebraMap V F D.u ^ 2) • + d (algebraMap V F D.Q₁ / algebraMap V F D.Q₀) = + (algebraMap V F D.t ^ (D.a + 1) * algebraMap V F D.u ^ 2) • + ∑ j, (D.t ^ (D.a + D.e - 1) * b j) • + d (algebraMap V F (D.Q j) / algebraMap V F D.Q₀) := by + change D.scaledDifferential D.Q₁ = _ + rw [hℓ, ← hb, Finset.smul_sum, Finset.smul_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + simp only [scaledDifferential, ← algebraMap_smul (R := V) (A := F) (M := Ω), smul_smul, + map_mul, map_pow] + ring_nf + exact smul_right_injective Ω hscale hleft + +theorem exists_maximalIdeal_coefficients (hinj : Function.Injective (algebraMap V F)) : + ∃ c : ι → V, (∀ j, c j ∈ maximalIdeal V) ∧ + d (algebraMap V F D.Q₁ / algebraMap V F D.Q₀) = + ∑ j, c j • d (algebraMap V F (D.Q j) / algebraMap V F D.Q₀) := by + obtain ⟨b, hb⟩ := D.exists_coefficients hinj + refine ⟨fun j ↦ D.t ^ (D.a + D.e - 1) * b j, fun j ↦ ?_, hb⟩ + have hpos : D.a + D.e - 1 = (D.a + D.e - 2) + 1 := by + have := D.one_le_a; have := D.one_le_e; omega + show D.t ^ (D.a + D.e - 1) * b j ∈ maximalIdeal V + rw [hpos, pow_succ] + exact Ideal.mul_mem_right _ _ (Ideal.mul_mem_left _ _ D.t_mem) + + +end VisibleDivisorFrame + +end + +end Stafford38.Geometry.DivisorTangentLattice diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialBoundaryExtension.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialBoundaryExtension.lean new file mode 100644 index 0000000000..f8c4965383 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialBoundaryExtension.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AsymptoticDivisorExistence +import Mathlib.RingTheory.DedekindDomain.IntegralClosure +import Mathlib.RingTheory.DedekindDomain.Dvr +import Mathlib.RingTheory.Ideal.Over +import Mathlib.RingTheory.Localization.AsSubring + +/-! +# Discrete boundary places in finite extensions + +This file closes the valuation-theoretic extension step whenever the ambient +function field is finite separable over the fraction field of the chosen DVR. +The construction is the classical one: take the integral closure, choose a +prime above the maximal ideal, and localize. Mathlib proves that the integral +closure is Dedekind and that its localization at a nonzero prime is a DVR. + +The resulting localization is realized as an actual subring of the ambient +field, so the theorem produces a `ValuationSubring`, not merely an abstract +local ring. The distinguished nonzero nonunit remains a nonunit at the +chosen place. + +For a general finitely generated extension, the remaining reduction is to +present the ambient field as a finite separable extension of the fraction +field of a DVR whose parameter maps to the selected coordinate. In +characteristic zero this is the usual finite transcendence-basis step; no +such presentation is assumed or named in the theorem proved here. +-/ + +namespace Stafford38.Geometry.DivisorialBoundaryExtension + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence + +noncomputable section + +universe u v w z + +attribute [-instance] instAlgebraAtPrimeFractionRing + +/-- A finite separable extension of the fraction field of a DVR has a +discrete valuation subring above the maximal ideal. + +The output is embedded in `L`. The element `a` is carried to a nonzero +nonunit of this valuation subring, and its underlying element of `L` is the +original image of `a`. -/ +theorem exists_discreteValuationSubring_over_maximalIdeal + {A : Type u} {F : Type v} {L : Type w} + [CommRing A] [IsDomain A] [IsDiscreteValuationRing A] + [Field F] [Algebra A F] [IsFractionRing A F] + [Field L] [Algebra A L] [Algebra F L] [IsScalarTower A F L] + [FiniteDimensional F L] [Algebra.IsSeparable F L] + (a : A) (ha_ne : a ≠ 0) (ha_nonunit : ¬IsUnit a) : + ∃ V : ValuationSubring L, + IsDiscreteValuationRing V.toSubring ∧ + ∃ aV : V.toSubring, + (aV : L) = algebraMap A L a ∧ + aV ≠ 0 ∧ ¬IsUnit aV := by + let C : Type w := integralClosure A L + letI : IsDedekindDomain C := + integralClosure.isDedekindDomain A F L + letI : IsFractionRing C L := + IsIntegralClosure.isFractionRing_of_finite_extension A F L C + have hinjAL : Function.Injective (algebraMap A L) := by + rw [IsScalarTower.algebraMap_eq A F L] + exact (algebraMap F L).injective.comp (IsFractionRing.injective A F) + have hinjAC : Function.Injective (algebraMap A C) := by + intro x y hxy + apply hinjAL + calc + algebraMap A L x = algebraMap C L (algebraMap A C x) := + (IsScalarTower.algebraMap_apply A C L x).symm + _ = algebraMap C L (algebraMap A C y) := congrArg (algebraMap C L) hxy + _ = algebraMap A L y := IsScalarTower.algebraMap_apply A C L y + have hm_ne : maximalIdeal A ≠ ⊥ := + IsDiscreteValuationRing.not_a_field A + letI : (maximalIdeal A).IsPrime := (maximalIdeal.isMaximal A).isPrime + have hker : RingHom.ker (algebraMap A C) ≤ maximalIdeal A := by + rw [(RingHom.injective_iff_ker_eq_bot _).mp + hinjAC] + exact bot_le + obtain ⟨Q, hQprime, hQcomap⟩ := + Ideal.exists_ideal_over_prime_of_isIntegral_of_isDomain + (R := A) (S := C) (maximalIdeal A) hker + letI : Q.IsPrime := hQprime + have hQ_ne : Q ≠ ⊥ := by + intro hQ + apply hm_ne + calc + maximalIdeal A = Q.comap (algebraMap A C) := hQcomap.symm + _ = (⊥ : Ideal C).comap (algebraMap A C) := by rw [hQ] + _ = RingHom.ker (algebraMap A C) := + (RingHom.ker_eq_comap_bot (algebraMap A C)).symm + _ = ⊥ := (RingHom.injective_iff_ker_eq_bot _).mp + hinjAC + let RQ : Type w := + Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors + letI : IsDiscreteValuationRing RQ := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + C hQ_ne RQ + let Rsub : Subring L := + (Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors).toSubring + have hmem : ∀ x : L, x ∈ Rsub ∨ x⁻¹ ∈ Rsub := by + intro x + have hfrac : IsFractionRing RQ L := inferInstance + obtain ⟨r, hr | hr⟩ := + (ValuationRing.isFractionRing_iff.mp hfrac).1 x + · left + change x ∈ (Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors).toSubring + rw [hr] + exact r.property + · right + change x⁻¹ ∈ (Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors).toSubring + rw [hr] + exact r.property + let V : ValuationSubring L := ValuationSubring.ofSubring Rsub hmem + have hVdvr : IsDiscreteValuationRing V.toSubring := by + change IsDiscreteValuationRing RQ + infer_instance + let aC : C := algebraMap A C a + have haC_mem : aC ∈ Q := by + have ha : a ∈ Q.comap (algebraMap A C) := by + rw [hQcomap, mem_maximalIdeal] + exact ha_nonunit + simpa only [Ideal.mem_comap, aC] using ha + let aRQ : RQ := algebraMap C RQ aC + have haRQ_mem : aRQ ∈ maximalIdeal RQ := by + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff RQ Q aC).2 haC_mem + have haRQ_nonunit : ¬IsUnit aRQ := by + exact mem_nonunits_iff.mp haRQ_mem + have haRQ_eq : (aRQ : L) = algebraMap A L a := by + change algebraMap C L (algebraMap A C a) = algebraMap A L a + exact IsScalarTower.algebraMap_apply A C L a + have haRQ_ne : aRQ ≠ 0 := by + intro ha0 + apply ha_ne + apply hinjAL + calc + algebraMap A L a = (aRQ : L) := haRQ_eq.symm + _ = ((0 : RQ) : L) := congrArg ((↑) : RQ → L) ha0 + _ = algebraMap A L 0 := by simp + refine ⟨V, hVdvr, aRQ, haRQ_eq, haRQ_ne, ?_⟩ + exact haRQ_nonunit + +/-- Characteristic-zero form. Finite extensions are automatically +separable, so no separability hypothesis is exposed to the caller. -/ +theorem exists_discreteValuationSubring_over_maximalIdeal_of_charZero + {A : Type u} {F : Type v} {L : Type w} + [CommRing A] [IsDomain A] [IsDiscreteValuationRing A] + [Field F] [CharZero F] [Algebra A F] [IsFractionRing A F] + [Field L] [Algebra A L] [Algebra F L] [IsScalarTower A F L] + [FiniteDimensional F L] + (a : A) (ha_ne : a ≠ 0) (ha_nonunit : ¬IsUnit a) : + ∃ V : ValuationSubring L, + IsDiscreteValuationRing V.toSubring ∧ + ∃ aV : V.toSubring, + (aV : L) = algebraMap A L a ∧ + aV ≠ 0 ∧ ¬IsUnit aV := by + letI : Algebra.IsSeparable F L := inferInstance + exact exists_discreteValuationSubring_over_maximalIdeal + (A := A) (F := F) (L := L) a ha_ne ha_nonunit + +/-- Specialization to the coordinate-zero DVR. If the ambient field is a +finite separable extension of the fraction field of `k[X]_(X)`, compatibly +with `X ↦ x`, then the previously conditional `DiscreteBoundaryRefinement` +exists unconditionally. -/ +theorem exists_discreteBoundaryRefinement_of_finiteExtension + (k : Type u) [Field k] + {K : Type w} [Field K] [Algebra k K] + (x : K) + [Algebra (CoordinateZeroLocalRing k) K] + [Algebra (FractionRing (CoordinateZeroLocalRing k)) K] + [IsScalarTower (CoordinateZeroLocalRing k) + (FractionRing (CoordinateZeroLocalRing k)) K] + [FiniteDimensional (FractionRing (CoordinateZeroLocalRing k)) K] + [Algebra.IsSeparable (FractionRing (CoordinateZeroLocalRing k)) K] + (hcoordinate : + algebraMap (CoordinateZeroLocalRing k) K + (algebraMap (Polynomial k) (CoordinateZeroLocalRing k) + (Polynomial.X : Polynomial k)) = x) : + Nonempty (DiscreteBoundaryRefinement k x) := by + let R := CoordinateZeroLocalRing k + let q : R := algebraMap (Polynomial k) R Polynomial.X + have hq_ne : q ≠ 0 := by + intro hq + apply Polynomial.X_ne_zero (R := k) + apply IsLocalization.injective R + (coordinateZeroPrime k).primeCompl_le_nonZeroDivisors + simpa only [q, map_zero] using hq + have hq_nonunit : ¬IsUnit q := by + rw [← mem_nonunits_iff, ← mem_maximalIdeal] + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff + R (coordinateZeroPrime k) Polynomial.X).2 + (Ideal.mem_span_singleton_self Polynomial.X) + obtain ⟨V, hVdvr, qV, hqV, hqV_ne, hqV_nonunit⟩ := + exists_discreteValuationSubring_over_maximalIdeal + (A := R) (F := FractionRing R) (L := K) q hq_ne hq_nonunit + exact ⟨{ + valuation := V + isDiscrete := hVdvr + coordinate := qV + coordinate_eq := hqV.trans hcoordinate + coordinate_ne := hqV_ne + coordinate_nonunit := hqV_nonunit + }⟩ + +/-- Relative-function-field form. The coefficient field `E` used to build +the `X`-adic DVR may differ from the original ground field `k`. This is the +form needed after adjoining the other members of a transcendence basis: +once `K` is finite separable over `E(x)`, the output is still a boundary +refinement indexed by the original ground field. -/ +theorem exists_discreteBoundaryRefinement_of_relativeFiniteExtension + (k : Type z) (E : Type u) [Field k] [Field E] + {K : Type w} [Field K] [Algebra k K] [Algebra E K] + (x : K) + [Algebra (CoordinateZeroLocalRing E) K] + [Algebra (FractionRing (CoordinateZeroLocalRing E)) K] + [IsScalarTower (CoordinateZeroLocalRing E) + (FractionRing (CoordinateZeroLocalRing E)) K] + [FiniteDimensional (FractionRing (CoordinateZeroLocalRing E)) K] + [Algebra.IsSeparable (FractionRing (CoordinateZeroLocalRing E)) K] + (hcoordinate : + algebraMap (CoordinateZeroLocalRing E) K + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) + (Polynomial.X : Polynomial E)) = x) : + Nonempty (DiscreteBoundaryRefinement k x) := by + obtain ⟨D⟩ := + exists_discreteBoundaryRefinement_of_finiteExtension E x hcoordinate + exact ⟨{ + valuation := D.valuation + isDiscrete := D.isDiscrete + coordinate := D.coordinate + coordinate_eq := D.coordinate_eq + coordinate_ne := D.coordinate_ne + coordinate_nonunit := D.coordinate_nonunit + }⟩ + +/-- Characteristic-zero specialization of the coordinate theorem. -/ +theorem exists_discreteBoundaryRefinement_of_finiteExtension_of_charZero + (k : Type u) [Field k] [CharZero k] + {K : Type w} [Field K] [Algebra k K] + (x : K) + [Algebra (CoordinateZeroLocalRing k) K] + [Algebra (FractionRing (CoordinateZeroLocalRing k)) K] + [IsScalarTower (CoordinateZeroLocalRing k) + (FractionRing (CoordinateZeroLocalRing k)) K] + [FiniteDimensional (FractionRing (CoordinateZeroLocalRing k)) K] + (hcoordinate : + algebraMap (CoordinateZeroLocalRing k) K + (algebraMap (Polynomial k) (CoordinateZeroLocalRing k) + (Polynomial.X : Polynomial k)) = x) : + Nonempty (DiscreteBoundaryRefinement k x) := by + letI : CharZero (CoordinateZeroLocalRing k) := + charZero_of_injective_algebraMap + (algebraMap k (CoordinateZeroLocalRing k)).injective + letI : CharZero (FractionRing (CoordinateZeroLocalRing k)) := + IsFractionRing.charZero_of_isFractionRing (CoordinateZeroLocalRing k) + letI : Algebra.IsIntegral + (FractionRing (CoordinateZeroLocalRing k)) K := + ⟨fun y ↦ (IsAlgebraic.of_finite + (FractionRing (CoordinateZeroLocalRing k)) y).isIntegral⟩ + letI : Algebra.IsSeparable + (FractionRing (CoordinateZeroLocalRing k)) K := inferInstance + exact exists_discreteBoundaryRefinement_of_finiteExtension + k x hcoordinate + +/-- Characteristic-zero relative-function-field form. -/ +theorem exists_discreteBoundaryRefinement_of_relativeFiniteExtension_of_charZero + (k : Type z) (E : Type u) [Field k] [Field E] [CharZero E] + {K : Type w} [Field K] [Algebra k K] [Algebra E K] + (x : K) + [Algebra (CoordinateZeroLocalRing E) K] + [Algebra (FractionRing (CoordinateZeroLocalRing E)) K] + [IsScalarTower (CoordinateZeroLocalRing E) + (FractionRing (CoordinateZeroLocalRing E)) K] + [FiniteDimensional (FractionRing (CoordinateZeroLocalRing E)) K] + (hcoordinate : + algebraMap (CoordinateZeroLocalRing E) K + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) + (Polynomial.X : Polynomial E)) = x) : + Nonempty (DiscreteBoundaryRefinement k x) := by + obtain ⟨D⟩ := + exists_discreteBoundaryRefinement_of_finiteExtension_of_charZero + E x hcoordinate + exact ⟨{ + valuation := D.valuation + isDiscrete := D.isDiscrete + coordinate := D.coordinate + coordinate_eq := D.coordinate_eq + coordinate_ne := D.coordinate_ne + coordinate_nonunit := D.coordinate_nonunit + }⟩ + + +attribute [instance] instAlgebraAtPrimeFractionRing + +end + +end Stafford38.Geometry.DivisorialBoundaryExtension diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameCore.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameCore.lean new file mode 100644 index 0000000000..a889ecc2ca --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameCore.lean @@ -0,0 +1,423 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.NormalizationHeightOne +import Mathlib + +/-! +# Divisorial visible-frame construction core + +This file packages the already checked valuation, DVR, Kähler, and +transcendence stages and states the assembly interface used by the dedicated +normalization, residue-algebraicity, and coefficient-field modules. +-/ + +open IsLocalRing Polynomial +open Stafford38.Geometry.NormalizationHeightOne + +noncomputable section + +universe u v + +namespace Stafford38.Geometry.LaneC + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +def coeffHom (E : IntermediateField k K) (V : ValuationSubring K) + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) : E →+* V.toSubring := + RingHom.codRestrict (IntermediateField.val E).toRingHom V.toSubring hEV + +def groundHom (E : IntermediateField k K) (V : ValuationSubring K) + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) : k →+* V.toSubring := + (coeffHom E V hEV).comp (algebraMap k E) + +def DivisorialVisibleFrameExistence : Prop := + ∀ (k K : Type u) [Field k] [CharZero k] [Field K] [Algebra k K] + (r : ℕ) (y : Fin r → K) (i : Fin r), + IntermediateField.adjoin k (Set.range y) = ⊤ → + Transcendental k (y i) → + ∃ (E : IntermediateField k K) (V : ValuationSubring K) + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (hVdvr : IsDiscreteValuationRing V.toSubring) + (hxV : y i ∈ V.toSubring), + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + letI : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + letI : Algebra k V.toSubring := (groundHom E V hEV).toAlgebra + Transcendental E (y i) ∧ + (⟨y i, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring ∧ + Module.Finite E (ResidueField V.toSubring) ∧ + Module.Finite V.toSubring (Ω[V.toSubring⁄k]) ∧ + (∀ (s : K) (q : Fin (r + 1) → V.toSubring), + (∀ a, (q a : K) = s * Fin.cases 1 y a) → + (∃ j, q j = 1) → ¬ IsUnit (q 0) → + Algebra.IsAlgebraic + (IntermediateField.adjoin k + (Set.range fun j : Fin r ↦ residue V.toSubring (q (Fin.succ j))) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring)) + +/-! The concrete localization model used by the place stage. -/ + +def placeSubalgebra (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] : Subalgebra A K := + Localization.subalgebra.ofField K p.primeCompl p.primeCompl_le_nonZeroDivisors + +def placeValuationSubring (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (h : ∀ z : K, z ∈ (placeSubalgebra A p).toSubring ∨ + z⁻¹ ∈ (placeSubalgebra A p).toSubring) : ValuationSubring K := + ValuationSubring.ofSubring (placeSubalgebra A p).toSubring h + +local instance valuationSubringToSubringIsLocal (V : ValuationSubring K) : + IsLocalRing V.toSubring := + ValuationSubring.isLocalRing V + +local instance placeSubalgebraAtPrime (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] : + IsLocalization.AtPrime (placeSubalgebra A p) p := by + unfold placeSubalgebra + infer_instance + +local instance placeSubalgebraIsLocal (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] : IsLocalRing (placeSubalgebra A p).toSubring := by + change IsLocalRing (placeSubalgebra A p) + exact IsLocalization.AtPrime.isLocalRing (placeSubalgebra A p) p + +local instance placeSubalgebraIsLocal' (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] : IsLocalRing (placeSubalgebra A p) := + IsLocalization.AtPrime.isLocalRing (placeSubalgebra A p) p + +theorem ofField_mem_algebraMap (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (a : A) : + (a : K) ∈ (placeSubalgebra A p).toSubring := by + change (a : K) ∈ placeSubalgebra A p + exact (placeSubalgebra A p).algebraMap_mem a + +theorem ofField_mem_algebraMap_v (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (h : ∀ z : K, z ∈ (placeSubalgebra A p).toSubring ∨ + z⁻¹ ∈ (placeSubalgebra A p).toSubring) (a : A) : + (a : K) ∈ (placeValuationSubring A p h).toSubring := by + exact ofField_mem_algebraMap A p a + +theorem ofField_mem_maximalIdeal_iff (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (a : A) : + (⟨(a : K), ofField_mem_algebraMap A p a⟩ : (placeSubalgebra A p).toSubring) ∈ + maximalIdeal (placeSubalgebra A p).toSubring ↔ a ∈ p := by + change algebraMap A (placeSubalgebra A p) a ∈ + maximalIdeal (placeSubalgebra A p) ↔ a ∈ p + exact IsLocalization.AtPrime.to_map_mem_maximal_iff + (placeSubalgebra A p) p a (h := placeSubalgebraIsLocal A p) + +theorem ofField_mem_maximalIdeal_iff_v (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (h : ∀ z : K, z ∈ (placeSubalgebra A p).toSubring ∨ + z⁻¹ ∈ (placeSubalgebra A p).toSubring) (a : A) : + (⟨(a : K), ofField_mem_algebraMap_v A p h a⟩ : + (placeValuationSubring A p h).toSubring) ∈ + maximalIdeal (placeValuationSubring A p h).toSubring ↔ a ∈ p := by + change algebraMap A (placeSubalgebra A p) a ∈ + maximalIdeal (placeSubalgebra A p) ↔ a ∈ p + exact IsLocalization.AtPrime.to_map_mem_maximal_iff + (placeSubalgebra A p) p a (h := placeSubalgebraIsLocal A p) + +theorem ofField_residue_surjective (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (z : ResidueField (placeSubalgebra A p).toSubring) : + ∃ (a b : A), b ∉ p ∧ + z = residue (placeSubalgebra A p).toSubring + ⟨(a : K), ofField_mem_algebraMap A p a⟩ / + residue (placeSubalgebra A p).toSubring + ⟨(b : K), ofField_mem_algebraMap A p b⟩ := by + obtain ⟨x, rfl⟩ := residue_surjective (R := (placeSubalgebra A p).toSubring) z + change ∃ (a b : A), b ∉ p ∧ + residue (placeSubalgebra A p).toSubring x = + residue (placeSubalgebra A p).toSubring + ⟨(a : K), ofField_mem_algebraMap A p a⟩ / + residue (placeSubalgebra A p).toSubring + ⟨(b : K), ofField_mem_algebraMap A p b⟩ + have hx : (x : K) ∈ placeSubalgebra A p := x.property + simp only [placeSubalgebra, Localization.subalgebra.ofField] at hx + obtain ⟨a, b, hb, hab⟩ := hx + refine ⟨a, b, ?_, ?_⟩ + · exact hb + · have hbinv : (algebraMap A K b)⁻¹ ∈ placeSubalgebra A p := by + simp only [placeSubalgebra, Localization.subalgebra.ofField] + exact ⟨1, b, hb, by simp⟩ + let binv : (placeSubalgebra A p).toSubring := + ⟨(algebraMap A K b)⁻¹, hbinv⟩ + have hxb : x = algebraMap A (placeSubalgebra A p) a * binv := by + apply Subtype.ext + simpa [binv] using hab + have hbA0 : b ≠ 0 := fun hbzero ↦ hb (hbzero ▸ p.zero_mem) + have hb0 : algebraMap A K b ≠ 0 := by + intro hbzero + apply hbA0 + apply Subtype.ext + exact hbzero + have hbmul : binv * algebraMap A (placeSubalgebra A p) b = 1 := by + apply Subtype.ext + exact inv_mul_cancel₀ hb0 + have hresinv : residue (placeSubalgebra A p).toSubring binv = + (residue (placeSubalgebra A p).toSubring + (algebraMap A (placeSubalgebra A p) b))⁻¹ := by + apply eq_inv_of_mul_eq_one_left + rw [← map_mul, hbmul, map_one] + calc + residue (placeSubalgebra A p).toSubring x = + residue (placeSubalgebra A p).toSubring + (algebraMap A (placeSubalgebra A p) a * binv) := by rw [hxb] + _ = residue (placeSubalgebra A p).toSubring + ⟨(a : K), ofField_mem_algebraMap A p a⟩ / + residue (placeSubalgebra A p).toSubring + ⟨(b : K), ofField_mem_algebraMap A p b⟩ := by + rw [map_mul, hresinv, div_eq_mul_inv] + rfl + +theorem ofField_residue_surjective_v (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (h : ∀ z : K, z ∈ (placeSubalgebra A p).toSubring ∨ + z⁻¹ ∈ (placeSubalgebra A p).toSubring) + (z : ResidueField (placeValuationSubring A p h).toSubring) : + ∃ (a b : A), b ∉ p ∧ + z = residue (placeValuationSubring A p h).toSubring + ⟨(a : K), ofField_mem_algebraMap_v A p h a⟩ / + residue (placeValuationSubring A p h).toSubring + ⟨(b : K), ofField_mem_algebraMap_v A p h b⟩ := by + exact ofField_residue_surjective A p z + +theorem ofField_glue (A : Subalgebra k K) [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (h : ∀ z : K, z ∈ (placeSubalgebra A p).toSubring ∨ + z⁻¹ ∈ (placeSubalgebra A p).toSubring) : + (∀ a : A, (a : K) ∈ (placeValuationSubring A p h).toSubring) ∧ + (∀ a : A, (⟨a, ofField_mem_algebraMap_v A p h a⟩ : + (placeValuationSubring A p h).toSubring) ∈ + maximalIdeal (placeValuationSubring A p h).toSubring ↔ a ∈ p) ∧ + (∀ z : ResidueField (placeValuationSubring A p h).toSubring, + ∃ (a b : A), b ∉ p ∧ + z = residue (placeValuationSubring A p h).toSubring + ⟨(a : K), ofField_mem_algebraMap_v A p h a⟩ / + residue (placeValuationSubring A p h).toSubring + ⟨(b : K), ofField_mem_algebraMap_v A p h b⟩) := by + refine ⟨fun a ↦ ofField_mem_algebraMap_v A p h a, + fun a ↦ ofField_mem_maximalIdeal_iff_v A p h a, + fun z ↦ ofField_residue_surjective_v A p h z⟩ + +/-! Explicitly named implementations of the five checked stages. -/ + +theorem isDiscreteValuationRing_of_isLocalization_atPrime + {A : Type*} [CommRing A] [IsDomain A] [IsNoetherianRing A] [IsIntegrallyClosed A] + (p : Ideal A) [p.IsPrime] (h : p.height = 1) + (S : Type*) [CommRing S] [IsDomain S] [Algebra A S] + [IsLocalization.AtPrime S p] : IsDiscreteValuationRing S := by + have hpb : p ≠ ⊥ := Ideal.ne_bot_of_height_eq_one h + letI : IsLocalRing S := IsLocalization.AtPrime.isLocalRing S p + letI : IsNoetherianRing S := IsLocalization.isNoetherianRing p.primeCompl S inferInstance + letI : IsIntegrallyClosed S := + isIntegrallyClosed_of_isLocalization S p.primeCompl p.primeCompl_le_nonZeroDivisors + have hnf : ¬ IsField S := IsLocalization.AtPrime.not_isField A hpb S + have hkd : Ring.KrullDimLE 1 S := by + rw [Ring.krullDimLE_iff, IsLocalization.AtPrime.ringKrullDim_eq_height p S, h] + norm_num + have h3 : IsIntegrallyClosed S ∧ ∃! P : Ideal S, P ≠ ⊥ ∧ P.IsPrime := by + refine ⟨inferInstance, IsLocalRing.maximalIdeal _, + ⟨IsLocalRing.isField_iff_maximalIdeal_eq.not.mp hnf, inferInstance⟩, ?_⟩ + rintro P ⟨hPb, hPp⟩ + exact IsLocalRing.eq_maximalIdeal (hPp.isMaximal_of_ne_bot hPb) + exact ((IsDiscreteValuationRing.TFAE S hnf).out 3 0).mp h3 + +theorem stage1_exists_valuationSubring_of_transcendental + {k K : Type*} [Field k] [Field K] [Algebra k K] (x : K) + (hx : Transcendental k x) : + ∃ W : ValuationSubring K, (∀ c : k, algebraMap k K c ∈ W) ∧ x ∈ W ∧ x⁻¹ ∉ W := by + classical + have hx0 : x ≠ 0 := fun h => hx (h ▸ isAlgebraic_zero) + let A : Subring K := (Algebra.adjoin k ({x} : Set K)).toSubring + have hxA : x ∈ A := Algebra.subset_adjoin (Set.mem_singleton x) + let I : Ideal A := Ideal.span {⟨x, hxA⟩} + have hI : I ≠ ⊤ := by + intro htop + have h1 : (1 : A) ∈ I := htop ▸ Submodule.mem_top + rw [Ideal.mem_span_singleton'] at h1 + obtain ⟨g, hg⟩ := h1 + have hg' : (g : K) * x = 1 := by + have := congrArg Subtype.val hg + simpa using this + obtain ⟨q, hq⟩ : ∃ q : Polynomial k, Polynomial.aeval x q = (g : K) := by + have hmem : (g : K) ∈ Algebra.adjoin k ({x} : Set K) := g.2 + rw [Algebra.adjoin_singleton_eq_range_aeval] at hmem + exact (AlgHom.mem_range _).1 hmem + apply hx + refine ⟨q * Polynomial.X - 1, ?_, ?_⟩ + · intro h0 + have hc := congrArg (fun p : Polynomial k => p.coeff 0) h0 + simp [Polynomial.mul_coeff_zero] at hc + · simp [map_sub, map_mul, hq, hg'] + obtain ⟨W, hAW, hIW⟩ := Ideal.image_subset_nonunits_valuationSubring I hI + have hxW : x ∈ W := hAW hxA + refine ⟨W, fun c => hAW (Subalgebra.algebraMap_mem _ c), hxW, ?_⟩ + intro hinv + have hxn : x ∈ W.nonunits := hIW + ⟨⟨x, hxA⟩, Ideal.mem_span_singleton_self _, rfl⟩ + rw [ValuationSubring.mem_nonunits_iff_exists_mem_maximalIdeal] at hxn + obtain ⟨hxW', hxm⟩ := hxn + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] at hxm + exact hxm (isUnit_iff_exists_inv.2 + ⟨⟨x⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hx0)⟩) + +theorem stage3_exists_height_one_prime_valuation + {k K : Type*} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) [IsNoetherianRing A] [IsIntegrallyClosed A] + [IsFractionRing A K] (x : A) (hx0 : x ≠ 0) (hxu : ¬ IsUnit x) : + ∃ p : Ideal A, ∃ _ : p.IsPrime, p.height = 1 ∧ x ∈ p ∧ + ∀ z : K, z ∈ Localization.subalgebra.ofField K p.primeCompl + p.primeCompl_le_nonZeroDivisors ∨ z⁻¹ ∈ + Localization.subalgebra.ofField K p.primeCompl + p.primeCompl_le_nonZeroDivisors := by + obtain ⟨p, hp, hp1⟩ := exists_height_one_minimal_prime hx0 hxu + letI := hp.isPrime + refine ⟨p, inferInstance, hp1, hp.1.2 (Ideal.mem_span_singleton_self x), ?_⟩ + set S := Localization.subalgebra.ofField K p.primeCompl + p.primeCompl_le_nonZeroDivisors with hS + letI : IsDiscreteValuationRing S := + isDiscreteValuationRing_of_isLocalization_atPrime p hp1 S + intro z + rcases ValuationRing.isInteger_or_isInteger S z with ⟨s, hs⟩ | ⟨s, hs⟩ + · left; rw [← hs]; exact s.2 + · right; rw [← hs]; exact s.2 + +theorem stage6_transcendental_of_mem_maximalIdeal + {k K : Type*} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) (x : K) (hx0 : x ≠ 0) + (hxV : x ∈ V.toSubring) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) : + Transcendental E x := by + intro halg + have hint : IsIntegral E x := halg.isIntegral + set a : E := (minpoly E x).coeff 0 with ha + have ha0 : a ≠ 0 := minpoly.coeff_zero_ne_zero hint hx0 + obtain ⟨q, hq⟩ := X_dvd_sub_C (p := minpoly E x) + have h1 : aeval x (minpoly E x - C a) = aeval x (X * q) := by rw [hq] + rw [map_sub, minpoly.aeval, aeval_C, zero_sub, map_mul, aeval_X] at h1 + have hqV : aeval x q ∈ V.toSubring := by + rw [aeval_eq_sum_range] + refine Subring.sum_mem _ fun n _ ↦ ?_ + rw [Algebra.smul_def] + exact Subring.mul_mem _ (hEV _) (Subring.pow_mem _ hxV n) + have haV : algebraMap E K a ∈ V.toSubring := hEV _ + have hmem : (⟨algebraMap E K a, haV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring := by + have : (⟨algebraMap E K a, haV⟩ : V.toSubring) = + -((⟨x, hxV⟩ : V.toSubring) * ⟨aeval x q, hqV⟩) := by + apply Subtype.ext + push_cast + exact neg_eq_iff_eq_neg.1 h1 + rw [this] + exact (Submodule.neg_mem_iff _).2 (Ideal.mul_mem_right _ _ hxm) + have hu : IsUnit (⟨algebraMap E K a, haV⟩ : V.toSubring) := by + refine isUnit_iff_exists_inv.2 ⟨⟨(algebraMap E K a)⁻¹, ?_⟩, Subtype.ext ?_⟩ + · have h : (algebraMap E K a)⁻¹ = ((a⁻¹ : E) : K) := by + first | simp | (rw [IntermediateField.coe_inv]; rfl) + rw [h]; exact hEV _ + · exact mul_inv_cancel₀ ((_root_.map_ne_zero _).2 ha0) + exact (mem_nonunits_iff.1 ((IsLocalRing.mem_maximalIdeal _).1 hmem)) hu + +theorem stage7_kaehler_finite_ofField + {k K : Type u} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) [Algebra.FiniteType k A] [IsFractionRing A K] + (p : Ideal A) [p.IsPrime] + (hk : ∀ c : k, algebraMap k K c ∈ + (Localization.subalgebra.ofField K p.primeCompl p.primeCompl_le_nonZeroDivisors).toSubring) : + letI : Algebra k + (Localization.subalgebra.ofField K p.primeCompl p.primeCompl_le_nonZeroDivisors).toSubring := + ((algebraMap k K).codRestrict _ hk).toAlgebra + Module.Finite + (Localization.subalgebra.ofField K p.primeCompl p.primeCompl_le_nonZeroDivisors).toSubring + (Ω[(Localization.subalgebra.ofField K p.primeCompl p.primeCompl_le_nonZeroDivisors).toSubring⁄k]) := by + exact (by + set S := Localization.subalgebra.ofField K p.primeCompl + p.primeCompl_le_nonZeroDivisors with hS + letI inst : Algebra k S.toSubring := ((algebraMap k K).codRestrict _ hk).toAlgebra + haveI : Algebra.EssFiniteType A S := Algebra.EssFiniteType.of_isLocalization S p.primeCompl + haveI : IsScalarTower k A S := IsScalarTower.of_algebraMap_eq fun c => + Subtype.ext (IsScalarTower.algebraMap_apply k A K c) + haveI : Algebra.EssFiniteType k A := Algebra.EssFiniteType.of_finiteType k A + haveI h1 : Algebra.EssFiniteType k S := Algebra.EssFiniteType.comp k A S + have h2 : inst = (inferInstance : Algebra k S) := by + apply Algebra.algebra_ext + intro c + rfl + haveI h3 : Algebra.EssFiniteType k S.toSubring := by + rw [h2] + exact h1 + exact KaehlerDifferential.finite k S.toSubring) + +/-! ## Assembly scaffold + +The declarations below intentionally expose exactly the three unresolved +construction stages. They are inputs, rather than axioms or placeholders, so a +future assembly proof can be checked by supplying S2, S4, and S5 separately. +The four other stage fields are already available as the theorems above. -/ + +def Stage2Obligation : Prop := + ∀ {k K : Type u} [Field k] [CharZero k] [Field K] [Algebra k K] + {r : ℕ} (y : Fin r → K) (i : Fin r) + (hgen : IntermediateField.adjoin k (Set.range y) = ⊤) + (hx : Transcendental k (y i)), + ∃ (j : Fin (r + 1)) (s : K) (A : Subalgebra k K), + s ≠ 0 ∧ (Fin.cases 1 y j : K) * s = 1 ∧ + (∀ a, (Fin.cases 1 y a : K) * s ∈ A) ∧ y i ∈ A ∧ + Algebra.FiniteType k A ∧ IsIntegrallyClosedIn A K ∧ IsFractionRing A K ∧ + (∀ a : A, IsIntegral (Algebra.adjoin k + (Set.range (fun a : Fin (r + 1) => (Fin.cases 1 y a : K) * s) ∪ {y i})) (a : K)) ∧ + (y i)⁻¹ ∉ A + +def Stage4Obligation : Prop := + ∀ {k K : Type u} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) (p : Ideal A) [p.IsPrime] + (V : ValuationSubring K) [IsLocalRing V.toSubring] + [Algebra k V.toSubring] [IsScalarTower k V.toSubring K] + (hAV : ∀ a : A, (a : K) ∈ V.toSubring) + (hp : ∀ a : A, (⟨a, hAV a⟩ : V.toSubring) ∈ maximalIdeal V.toSubring ↔ a ∈ p) + (hsurj : ∀ z : ResidueField V.toSubring, ∃ (a b : A), b ∉ p ∧ + z = residue V.toSubring ⟨a, hAV a⟩ / residue V.toSubring ⟨b, hAV b⟩) + {ι : Type v} (c : ι → K) (hc : ∀ i, c i ∈ A) + (hint : ∀ a : A, IsIntegral (Algebra.adjoin k (Set.range c)) (a : K)), + Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range fun i => + residue V.toSubring ⟨c i, hAV ⟨c i, hc i⟩⟩) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring) + +def Stage5Obligation : Prop := + ∀ {k K : Type u} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) [Algebra.FiniteType k A] (p : Ideal A) [p.IsPrime] + (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hAV : ∀ a : A, (a : K) ∈ V.toSubring) + (hp : ∀ a : A, (⟨a, hAV a⟩ : V.toSubring) ∈ maximalIdeal V.toSubring ↔ a ∈ p) + (hsurj : ∀ z : ResidueField V.toSubring, ∃ (a b : A), b ∉ p ∧ + z = residue V.toSubring ⟨a, hAV a⟩ / residue V.toSubring ⟨b, hAV b⟩), + ∃ (E : IntermediateField k K) (hEV : ∀ z : E, (z : K) ∈ V.toSubring), + letI : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + Module.Finite E (ResidueField V.toSubring) + +structure AssemblyScaffold : Prop where + stage2 : Stage2Obligation.{u} + stage4 : Stage4Obligation.{u, v} + stage5 : Stage5Obligation.{u} + +theorem assembly_scaffold_of_obligations + (stage2 : Stage2Obligation.{u}) (stage4 : Stage4Obligation.{u, v}) + (stage5 : Stage5Obligation.{u}) : AssemblyScaffold.{u, v} := + ⟨stage2, stage4, stage5⟩ + + +end Stafford38.Geometry.LaneC + +end diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage2.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage2.lean new file mode 100644 index 0000000000..f98ad3ead7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage2.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Valuation.ValuationSubring +import Mathlib.RingTheory.IntegralClosure.IntegrallyClosed +import Mathlib.RingTheory.Localization.FractionRing +import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs +import Mathlib.RingTheory.FiniteType +import LeanPool.Stafford38.Stafford38.Geometry.NormalizationHeightOne + +open IsLocalRing +open scoped nonZeroDivisors + +noncomputable section +universe u + +namespace Stafford38.Geometry.DivisorialVisibleFrameStage2 + +section Chart +variable {K : Type u} [Field K] + +private lemma chart_of_valuation + {r : ℕ} (Y : Fin (r + 1) → K) (W : ValuationSubring K) (hY : Y 0 = 1) : + ∃ (j : Fin (r + 1)) (s : K), s ≠ 0 ∧ Y j * s = 1 ∧ + ∀ a, Y a * s ∈ W.toSubring := by + classical + let S : Set (Fin (r + 1)) := {a | Y a ≠ 0} + have hS : S.Nonempty := ⟨0, by simp [S, hY]⟩ + letI : LE (Fin (r + 1)) := + ⟨fun a b => Y b ≠ 0 ∧ Y a / Y b ∈ W.toSubring⟩ + have htrans : IsTrans (Fin (r + 1)) LE.le := by + constructor + intro a b c hab hbc + rcases hab with ⟨hb, hab⟩ + rcases hbc with ⟨hc, hbc⟩ + refine ⟨hc, ?_⟩ + have := W.toSubring.mul_mem hab hbc + rw [div_eq_mul_inv] at hab hbc ⊢ + simpa [div_eq_mul_inv, mul_assoc, hb] using this + letI : IsTrans (Fin (r + 1)) LE.le := htrans + obtain ⟨j, hjS, hjmax⟩ := S.toFinite.exists_maximalFor id S hS + have hj0 : Y j ≠ 0 := hjS + let s := (Y j)⁻¹ + refine ⟨j, s, inv_ne_zero hj0, ?_, ?_⟩ + · simp [s, hj0] + · intro a + by_cases ha : Y a = 0 + · rw [ha, zero_mul] + exact W.zero_mem + have haS : a ∈ S := ha + rcases W.mem_or_inv_mem (Y a / Y j) with h | h + · simpa [s, div_eq_mul_inv, mul_comm] using h + · have h' : Y a / Y j ∈ W.toSubring := by + apply (hjmax haS ⟨ha, ?_⟩).2 + simpa [div_eq_mul_inv, mul_comm] using h + simpa [s, div_eq_mul_inv, mul_comm] using h' + +end Chart + +section Generation +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +private lemma normalized_generates_top + {r : ℕ} (y : Fin r → K) (i : Fin r) (s : K) (hs : s ≠ 0) + (hgen : IntermediateField.adjoin k (Set.range y) = ⊤) : + IntermediateField.adjoin k + (Set.range (fun a : Fin (r + 1) => (Fin.cases 1 y a : K) * s) ∪ {y i}) = ⊤ := by + apply top_unique + rw [← hgen] + apply IntermediateField.adjoin_le_iff.2 + intro a ha + rcases ha with ⟨a, rfl⟩ + apply IntermediateField.mem_adjoin_iff_div.mpr + refine ⟨(Fin.cases 1 y (Fin.succ a) : K) * s, ?_, s, ?_, ?_⟩ + · exact Algebra.subset_adjoin (R := k) (A := K) + (Set.mem_union_left _ (Set.mem_range_self _)) + · have h0 : (Fin.cases 1 y (0 : Fin (r + 1)) : K) * s ∈ + Algebra.adjoin k + (Set.range (fun a : Fin (r + 1) => (Fin.cases 1 y a : K) * s) ∪ {y i}) := + Algebra.subset_adjoin (R := k) (A := K) + (Set.mem_union_left _ (Set.mem_range_self (0 : Fin (r + 1)))) + simpa only [Fin.cases_zero, one_mul] using h0 + · simp only [Fin.cases_succ] + exact (eq_div_iff hs).2 rfl + +end Generation + +section Pivot + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +private theorem exists_valuationSubring_of_transcendental + (x : K) (hx : Transcendental k x) : + ∃ W : ValuationSubring K, (∀ c : k, algebraMap k K c ∈ W) ∧ x ∈ W ∧ x⁻¹ ∉ W := by + classical + have hx0 : x ≠ 0 := fun h => hx (h ▸ isAlgebraic_zero) + let R : Subring K := (Algebra.adjoin k ({x} : Set K)).toSubring + have hxR : x ∈ R := Algebra.subset_adjoin (Set.mem_singleton x) + let I : Ideal R := Ideal.span {⟨x, hxR⟩} + have hI : I ≠ ⊤ := by + intro htop + have h1 : (1 : R) ∈ I := htop ▸ Submodule.mem_top + rw [Ideal.mem_span_singleton'] at h1 + obtain ⟨g, hg⟩ := h1 + have hg' : (g : K) * x = 1 := by + have := congrArg Subtype.val hg + simpa using this + obtain ⟨q, hq⟩ : ∃ q : Polynomial k, Polynomial.aeval x q = (g : K) := by + have hmem : (g : K) ∈ Algebra.adjoin k ({x} : Set K) := g.2 + rw [Algebra.adjoin_singleton_eq_range_aeval] at hmem + exact (AlgHom.mem_range _).1 hmem + apply hx + refine ⟨q * Polynomial.X - 1, ?_, ?_⟩ + · intro h0 + have hc := congrArg (fun p : Polynomial k => p.coeff 0) h0 + simp [Polynomial.mul_coeff_zero] at hc + · simp [map_sub, map_mul, hq, hg'] + obtain ⟨W, hRW, hIW⟩ := Ideal.image_subset_nonunits_valuationSubring I hI + have hxW : x ∈ W := hRW hxR + refine ⟨W, fun c => hRW (Subalgebra.algebraMap_mem _ c), hxW, ?_⟩ + intro hinv + have hxn : x ∈ W.nonunits := hIW ⟨⟨x, hxR⟩, Ideal.mem_span_singleton_self _, rfl⟩ + rw [ValuationSubring.mem_nonunits_iff_exists_mem_maximalIdeal] at hxn + obtain ⟨hxW', hxm⟩ := hxn + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] at hxm + exact hxm (isUnit_iff_exists_inv.2 + ⟨⟨x⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hx0)⟩) + +end Pivot + +open Stafford38.Geometry.NormalizationHeightOne + +theorem stage2_exists_chart_normalization + {k K : Type u} [Field k] [CharZero k] [Field K] [Algebra k K] + {r : ℕ} (y : Fin r → K) (i : Fin r) + (hgen : IntermediateField.adjoin k (Set.range y) = ⊤) (hx : Transcendental k (y i)) : + ∃ (j : Fin (r + 1)) (s : K) (A : Subalgebra k K), + s ≠ 0 ∧ (Fin.cases 1 y j : K) * s = 1 ∧ + (∀ a, (Fin.cases 1 y a : K) * s ∈ A) ∧ y i ∈ A ∧ + Algebra.FiniteType k A ∧ IsIntegrallyClosedIn A K ∧ IsFractionRing A K ∧ + (∀ a : A, IsIntegral (Algebra.adjoin k + (Set.range (fun a : Fin (r + 1) => (Fin.cases 1 y a : K) * s) ∪ {y i})) (a : K)) ∧ + (y i)⁻¹ ∉ A := by + classical + obtain ⟨W, hkW, hxiW, hxiInvW⟩ := exists_valuationSubring_of_transcendental (y i) hx + let Y : Fin (r + 1) → K := Fin.cases 1 y + obtain ⟨j, s, hs, hjs, hYsW⟩ := chart_of_valuation Y W (by simp [Y]) + let C₀ : Subalgebra k K := + Algebra.adjoin k (Set.range (fun a : Fin (r + 1) => Y a * s) ∪ {y i}) + let SW : Subalgebra k K := + { W.toSubring with algebraMap_mem' := hkW } + have hC₀W : C₀ ≤ SW := by + apply Algebra.adjoin_le + rintro z (⟨a, rfl⟩ | rfl) + · exact hYsW a + · exact hxiW + have htop : IntermediateField.adjoin k + (Set.range (fun a : Fin (r + 1) => Y a * s) ∪ {y i}) = ⊤ := + normalized_generates_top y i s hs hgen + letI hC₀fr : IsFractionRing C₀ K := IsFractionRing.of_field C₀ K fun z => by + have hz : z ∈ IntermediateField.adjoin k + (Set.range (fun a : Fin (r + 1) => Y a * s) ∪ {y i}) := by + rw [htop] + exact Set.mem_univ z + rw [IntermediateField.mem_adjoin_iff_div] at hz + rcases hz with ⟨a, ha, b, hb, hab⟩ + exact ⟨⟨a, ha⟩, ⟨b, hb⟩, hab⟩ + let A₀ : Subalgebra C₀ K := integralClosure C₀ K + let A : Subalgebra k K := A₀.restrictScalars k + have hC₀A : C₀ ≤ A := fun z hz => A₀.algebraMap_mem ⟨z, hz⟩ + letI : IsIntegrallyClosedIn W.toSubring K := + inferInstanceAs (IsIntegrallyClosedIn W K) + have hA₀W : A₀.toSubring ≤ W.toSubring := by + change (integralClosure C₀ K).toSubring ≤ W.toSubring + apply (Subring.integralClosure_subring_le_iff (S := C₀) (T := W.toSubring)).2 + exact hC₀W + have hyA : y i ∈ A := by + exact A₀.algebraMap_mem ⟨y i, Algebra.subset_adjoin (Set.mem_union_right _ (Set.mem_singleton _))⟩ + have hnormA : ∀ a, Y a * s ∈ A := by + intro a + exact A₀.algebraMap_mem + ⟨Y a * s, Algebra.subset_adjoin (Set.mem_union_left _ (Set.mem_range_self a))⟩ + have hinvA : (y i)⁻¹ ∉ A := fun h => hxiInvW (hA₀W h) + haveI hC₀ft : Algebra.FiniteType k C₀ := Algebra.FiniteType.adjoin_of_finite + (Set.Finite.union (Set.finite_range _) (Set.finite_singleton _)) + let D : Subalgebra C₀ (FractionRing C₀) := integralClosure C₀ (FractionRing C₀) + haveI hDfin : Module.Finite C₀ D := + finite_normalization_of_fg_domain k C₀ D + let e : FractionRing C₀ ≃ₐ[C₀] K := + IsLocalization.algEquiv C₀⁰ (FractionRing C₀) K + haveI hA₀fin : Module.Finite C₀ A₀ := + Module.Finite.equiv e.mapIntegralClosure.toLinearEquiv + have hsub : A.toSubring = A₀.toSubring := rfl + let er : A ≃+* A₀ := RingEquiv.subringCongr hsub + letI : Algebra C₀ A := + (er.symm.toRingHom.comp (algebraMap C₀ A₀)).toAlgebra + let ea : A₀ ≃ₐ[C₀] A := AlgEquiv.ofRingEquiv (f := er.symm) (fun _ => rfl) + letI : IsScalarTower k C₀ A := IsScalarTower.of_algebraMap_eq fun _ => by + apply Subtype.ext + rfl + letI : IsScalarTower C₀ A K := IsScalarTower.of_algebraMap_eq fun _ => rfl + haveI hAfin : Module.Finite C₀ A := Module.Finite.equiv ea.toLinearEquiv + have hAft : Algebra.FiniteType k A := + Algebra.FiniteType.trans hC₀ft (inferInstance : Algebra.FiniteType C₀ A) + have hAic : IsIntegrallyClosedIn A K := by + apply Subring.isIntegrallyClosedIn_iff.mpr + intro x hx + change x ∈ integralClosure C₀ K + exact isIntegral_trans (R := C₀) (A := A) x hx + have hAfr : IsFractionRing A K := IsFractionRing.of_field A K fun z => by + obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective C₀ z + refine ⟨⟨a, hC₀A a.2⟩, ⟨b, hC₀A b.2⟩, ?_⟩ + change z = (a : K) / (b : K) + exact hab.symm + refine ⟨j, s, A, hs, hjs, hnormA, hyA, hAft, hAic, hAfr, ?_, hinvA⟩ + intro a + exact a.2 + + +end Stafford38.Geometry.DivisorialVisibleFrameStage2 diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage4.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage4.lean new file mode 100644 index 0000000000..c45b4e1271 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage4.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Valuation.Basic +import Mathlib.RingTheory.Valuation.ValuationSubring +import Mathlib.RingTheory.LocalRing.ResidueField.Basic +import Mathlib.RingTheory.Algebraic.Basic +import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic +import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs + +open IsLocalRing +noncomputable section +universe u v + +namespace Stafford38.Geometry.DivisorialVisibleFrameStage4 + +theorem stage4_residueField_isAlgebraic_of_isIntegral + {k K : Type u} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) (p : Ideal A) [p.IsPrime] + (V : ValuationSubring K) [IsLocalRing V.toSubring] + [Algebra k V.toSubring] [IsScalarTower k V.toSubring K] + (hAV : ∀ a : A, (a : K) ∈ V.toSubring) + (hp : ∀ a : A, (⟨a, hAV a⟩ : V.toSubring) ∈ maximalIdeal V.toSubring ↔ a ∈ p) + (hsurj : ∀ z : ResidueField V.toSubring, ∃ (a b : A), b ∉ p ∧ + z = residue V.toSubring ⟨a, hAV a⟩ / residue V.toSubring ⟨b, hAV b⟩) + {ι : Type v} (c : ι → K) (hc : ∀ i, c i ∈ A) + (hint : ∀ a : A, IsIntegral (Algebra.adjoin k (Set.range c)) (a : K)) : + Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range fun i => residue V.toSubring ⟨c i, hAV ⟨c i, hc i⟩⟩) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring) := by + let C : Subalgebra k K := Algebra.adjoin k (Set.range c) + have hCA : C ≤ A := by + apply Algebra.adjoin_le + rintro z ⟨i, rfl⟩ + exact hc i + let cV : C →+* V.toSubring := + RingHom.codRestrict C.val.toRingHom V.toSubring (fun z => hAV ⟨z, hCA z.property⟩) + let ρ : V.toSubring →+* ResidueField V.toSubring := residue V.toSubring + let φ : C →+* ResidueField V.toSubring := ρ.comp cV + let L : IntermediateField k (ResidueField V.toSubring) := + IntermediateField.adjoin k (Set.range fun i => ρ ⟨c i, hAV ⟨c i, hc i⟩⟩) + have hφL : ∀ z : C, φ z ∈ L := by + intro z + apply Algebra.adjoin_induction + (p := fun x hx => φ ⟨x, hx⟩ ∈ L) + · intro x hx + rcases hx with ⟨i, rfl⟩ + exact IntermediateField.subset_adjoin k _ ⟨i, rfl⟩ + · intro a + have hcV : cV (algebraMap k C a) = algebraMap k V.toSubring a := by + apply Subtype.ext + change (algebraMap k K) a = + (algebraMap V.toSubring K) ((algebraMap k V.toSubring) a) + exact IsScalarTower.algebraMap_apply k V.toSubring K a + have hbase : φ (algebraMap k C a) = + algebraMap k (ResidueField V.toSubring) a := by + calc + φ (algebraMap k C a) = ρ (algebraMap k V.toSubring a) := by + simp only [φ, RingHom.comp_apply, hcV] + _ = algebraMap k (ResidueField V.toSubring) a := by + change residue V.toSubring (algebraMap k V.toSubring a) = _ + rw [← ResidueField.algebraMap_eq] + exact (IsScalarTower.algebraMap_apply k V.toSubring + (ResidueField V.toSubring) a).symm + have hmem : φ (algebraMap k C a) ∈ L := by + rw [hbase] + exact L.algebraMap_mem a + have harg : (⟨(algebraMap k K) a, C.algebraMap_mem a⟩ : C) = algebraMap k C a := by + apply Subtype.ext + rfl + simpa [harg] using hmem + · intro a b haC hbC ha hb + change φ ((⟨a, haC⟩ : C) + ⟨b, hbC⟩) ∈ L + rw [map_add] + exact add_mem ha hb + · intro a b haC hbC ha hb + change φ ((⟨a, haC⟩ : C) * ⟨b, hbC⟩) ∈ L + rw [map_mul] + exact mul_mem ha hb + let cL : C →+* L := φ.codRestrict L.toSubring hφL + letI : Algebra C V.toSubring := cV.toAlgebra + letI : Algebra C (ResidueField V.toSubring) := φ.toAlgebra + letI : IsScalarTower C V.toSubring K := + IsScalarTower.of_algebraMap_eq (fun _ => rfl) + letI : IsScalarTower C V.toSubring (ResidueField V.toSubring) := by + constructor + intro x y z + change ρ (cV x) * ρ y * z = ρ (cV x) * (ρ y * z) + exact mul_assoc _ _ _ + letI : IsScalarTower C C V.toSubring := + IsScalarTower.of_algebraMap_eq (fun _ => rfl) + letI : IsScalarTower C C (ResidueField V.toSubring) := + IsScalarTower.of_algebraMap_eq (fun _ => rfl) + letI : Algebra C L := cL.toAlgebra + letI : IsScalarTower C L (ResidueField V.toSubring) := by + apply IsScalarTower.of_algebraMap_eq + intro x + rfl + have hmap : ∀ a : A, IsIntegral C (ρ ⟨a, hAV a⟩) := by + intro a + let av : V.toSubring := ⟨a, hAV a⟩ + have haK : IsIntegral C (a : K) := by simpa [C] using hint a + have haV : IsIntegral C av := by + apply (isIntegral_algebraMap_iff (R := C) (A := V.toSubring) + (B := K) (fun x y h => Subtype.ext h)).mp + change IsIntegral C (a : K) + exact haK + let f : V.toSubring →ₐ[C] ResidueField V.toSubring := + { ρ with + commutes' := by + intro x + rfl } + exact IsIntegral.map f haV + refine ⟨fun z => ?_⟩ + obtain ⟨a, b, hb, hz⟩ := hsurj z + have ha := hmap a + have hbin := hmap b + have hbp : ρ ⟨b, hAV b⟩ ≠ 0 := by + intro hzero + have hnotmax : (⟨b, hAV b⟩ : V.toSubring) ∉ maximalIdeal V.toSubring := by + intro hmem + exact hb ((hp b).mp hmem) + exact ((residue_ne_zero_iff_isUnit _).2 + ((notMem_maximalIdeal).1 hnotmax)) hzero + have haL : IsIntegral L (ρ ⟨a, hAV a⟩) := IsIntegral.tower_top ha + have hbL : IsIntegral L (ρ ⟨b, hAV b⟩) := IsIntegral.tower_top hbin + have h_ainv : IsAlgebraic L (ρ ⟨a, hAV a⟩) := haL.isAlgebraic + have h_binv : IsAlgebraic L (ρ ⟨b, hAV b⟩) := hbL.isAlgebraic + rw [hz] + exact h_ainv.mul h_binv.inv + + +theorem stage4'_isAlgebraic_of_normalized_column + {k K : Type u} [Field k] [Field K] [Algebra k K] + (V : ValuationSubring K) [IsLocalRing V.toSubring] [Algebra k V.toSubring] + {r : ℕ} (y : Fin r → K) (j : Fin (r + 1)) (hj : j ≠ 0) (s₀ : K) + (c : Fin (r + 1) → V.toSubring) (hc : ∀ a, (c a : K) = (Fin.cases 1 y a : K) * s₀) + (hcj : c j = 1) + (halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range fun a => residue V.toSubring (c a)) : + IntermediateField k (ResidueField V.toSubring)) (ResidueField V.toSubring)) + (s : K) (q : Fin (r + 1) → V.toSubring) (hq : ∀ a, (q a : K) = s * Fin.cases 1 y a) + (hq1 : ∃ j', q j' = 1) (hq0 : ¬ IsUnit (q 0)) : + Algebra.IsAlgebraic + (IntermediateField.adjoin k + (Set.range fun b : Fin r => residue V.toSubring (q (Fin.succ b))) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring) := by + classical + let ρ : V.toSubring →+* ResidueField V.toSubring := residue V.toSubring + let Lc : IntermediateField k (ResidueField V.toSubring) := + IntermediateField.adjoin k (Set.range fun a => ρ (c a)) + let Lq : IntermediateField k (ResidueField V.toSubring) := + IntermediateField.adjoin k (Set.range fun b : Fin r => ρ (q (Fin.succ b))) + let lam : ResidueField V.toSubring := ρ (q j) + have hcjK : (Fin.cases 1 y j : K) * s₀ = 1 := by + have := congrArg (fun z : V.toSubring => (z : K)) hcj + simpa [hc j] using this + have hprodK (a : Fin (r + 1)) : (q a : K) = (q j : K) * (c a : K) := by + rw [hq a, hq j, hc a] + calc + s * Fin.cases 1 y a = (s * Fin.cases 1 y a) * 1 := by rw [mul_one] + _ = (s * Fin.cases 1 y a) * ((Fin.cases 1 y j) * s₀) := by rw [hcjK] + _ = (s * Fin.cases 1 y j) * ((Fin.cases 1 y a) * s₀) := by ring + have hprodV (a : Fin (r + 1)) : q a = q j * c a := by + apply Subtype.ext + exact hprodK a + have hprod (a : Fin (r + 1)) : ρ (q a) = lam * ρ (c a) := by + rw [hprodV a, map_mul] + obtain ⟨j', hj'⟩ := hq1 + have hlam : lam ≠ 0 := by + intro hzero + have hqj' : IsUnit (q j') := by rw [hj']; exact isUnit_one + have hnz : ρ (q j') ≠ 0 := (residue_ne_zero_iff_isUnit _).2 hqj' + apply hnz + rw [hprod j', hzero, zero_mul] + obtain ⟨jt, hjt⟩ := Fin.exists_succ_eq_of_ne_zero hj + have hlammem : lam ∈ Lq := by + change ρ (q j) ∈ Lq + rw [← hjt] + exact IntermediateField.subset_adjoin k _ ⟨jt, rfl⟩ + have hq0res : ρ (q 0) = 0 := by + by_contra hnz + exact hq0 ((residue_ne_zero_iff_isUnit _).1 hnz) + have hc0res : ρ (c 0) = 0 := by + have h := hprod 0 + rw [hq0res] at h + exact (mul_eq_zero.mp h.symm).resolve_left hlam + have hctail (b : Fin r) : ρ (c (Fin.succ b)) = lam⁻¹ * ρ (q (Fin.succ b)) := by + calc + ρ (c (Fin.succ b)) = lam⁻¹ * (lam * ρ (c (Fin.succ b))) := by + rw [← mul_assoc, inv_mul_cancel₀ hlam, one_mul] + _ = lam⁻¹ * ρ (q (Fin.succ b)) := by rw [← hprod] + have hcLq : ∀ a : Fin (r + 1), ρ (c a) ∈ Lq := by + intro a + refine Fin.cases ?_ (fun b => ?_) a + · rw [hc0res] + exact Lq.zero_mem + · rw [hctail] + exact Lq.mul_mem (Lq.inv_mem hlammem) + (IntermediateField.subset_adjoin k _ ⟨b, rfl⟩) + have hLcLq : Lc ≤ Lq := by + intro z hz + apply IntermediateField.adjoin_induction (F := k) + (E := ResidueField V.toSubring) + (s := Set.range fun a => ρ (c a)) + (p := fun x hx => x ∈ Lq) + · intro x hx + rcases hx with ⟨a, rfl⟩ + exact hcLq a + · intro a + exact Lq.algebraMap_mem a + · intro a b _ _ ha hb + simpa only [map_add] using Lq.add_mem ha hb + · intro a _ ha + simpa only [map_inv₀] using Lq.inv_mem ha + · intro a b _ _ ha hb + simpa only [map_mul] using Lq.mul_mem ha hb + · exact hz + letI : Algebra Lc Lq := (IntermediateField.inclusion hLcLq).toAlgebra + letI : IsScalarTower Lc Lq (ResidueField V.toSubring) := + IsScalarTower.of_algebraMap_eq (fun _ => rfl) + exact ⟨fun z => + (Algebra.IsAlgebraic.isAlgebraic z).extendScalars + (IntermediateField.inclusion_injective hLcLq)⟩ + + +end Stafford38.Geometry.DivisorialVisibleFrameStage4 diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage5.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage5.lean new file mode 100644 index 0000000000..71a44c7dcb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStage5.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.NormalizationHeightOne + +open IsLocalRing + +noncomputable section + +universe u + +namespace Stafford38.Geometry.DivisorialVisibleFrameStage5 + +def coeffHom {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) (V : ValuationSubring K) + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) : E →+* V.toSubring := + RingHom.codRestrict (IntermediateField.val E).toRingHom V.toSubring hEV + +theorem stage5_exists_coefficientField + {k K : Type u} [Field k] [Field K] [Algebra k K] + (A : Subalgebra k K) [Algebra.FiniteType k A] (p : Ideal A) [p.IsPrime] + (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hAV : ∀ a : A, (a : K) ∈ V.toSubring) + (hp : ∀ a : A, (⟨a, hAV a⟩ : V.toSubring) ∈ maximalIdeal V.toSubring ↔ a ∈ p) + (hsurj : ∀ z : ResidueField V.toSubring, ∃ (a b : A), b ∉ p ∧ + z = residue V.toSubring ⟨a, hAV a⟩ / residue V.toSubring ⟨b, hAV b⟩) : + ∃ (E : IntermediateField k K) (hEV : ∀ z : E, (z : K) ∈ V.toSubring), + letI : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + Module.Finite E (ResidueField V.toSubring) := by + classical + let AV : A →+* V.toSubring := + RingHom.codRestrict (Subalgebra.val A).toRingHom V.toSubring hAV + letI : Algebra k V.toSubring := (AV.comp (algebraMap k A)).toAlgebra + letI : Algebra k (ResidueField V.toSubring) := + ((residue V.toSubring).comp (algebraMap k V.toSubring)).toAlgebra + letI : Nontrivial (A ⧸ p) := + Ideal.Quotient.nontrivial_iff.mpr (inferInstance : p.IsPrime).ne_top + obtain ⟨s, g, hg, hgfin⟩ := exists_finite_inj_algHom_of_fg k (A ⧸ p) + choose a ha using fun i : Fin s ↦ Ideal.Quotient.mk_surjective (g (MvPolynomial.X i)) + let t : Fin s → K := fun i ↦ (a i : K) + have heval : MvPolynomial.aeval t = + (Subalgebra.val A).comp (MvPolynomial.aeval a) := by + ext i + simp [t] + have hg_eval : g = (Ideal.Quotient.mkₐ k p).comp (MvPolynomial.aeval a) := by + ext i + simpa using (ha i).symm + have ht_independent : AlgebraicIndependent k t := + algebraicIndependent_iff_injective_aeval.mpr fun f q hfq ↦ by + apply hg + rw [hg_eval] + apply congrArg (fun x : A ↦ Ideal.Quotient.mk p x) + apply Subtype.ext + exact (congrArg (fun e : MvPolynomial (Fin s) k →ₐ[k] K ↦ e f) heval).symm |>.trans + hfq |>.trans (congrArg (fun e : MvPolynomial (Fin s) k →ₐ[k] K ↦ e q) heval) + let E : IntermediateField k K := IntermediateField.adjoin k (Set.range t) + have eval_mem (f : MvPolynomial (Fin s) k) : + MvPolynomial.aeval t f ∈ V.toSubring := by + rw [heval] + exact hAV (MvPolynomial.aeval a f) + have eval_ne_p {f : MvPolynomial (Fin s) k} (hf : f ≠ 0) : + MvPolynomial.aeval a f ∉ p := by + intro hfp + have hgf : g f = 0 := by + rw [hg_eval] + exact Ideal.Quotient.eq_zero_iff_mem.mpr hfp + exact hf (hg (hgf.trans (map_zero g).symm)) + have inv_eval_mem (f : MvPolynomial (Fin s) k) : + (MvPolynomial.aeval t f)⁻¹ ∈ V.toSubring := by + by_cases hf : f = 0 + · simp [hf] + · let vf : V.toSubring := + ⟨(MvPolynomial.aeval a f : A), hAV (MvPolynomial.aeval a f)⟩ + have hvf : ((vf : V.toSubring) : K) = MvPolynomial.aeval t f := by + change A.val (MvPolynomial.aeval a f) = MvPolynomial.aeval t f + exact (congrArg (fun e : MvPolynomial (Fin s) k →ₐ[k] K ↦ e f) heval).symm + have hv_not_mem : vf ∉ maximalIdeal V.toSubring := + (hp (MvPolynomial.aeval a f)).not.mpr (eval_ne_p hf) + have hv_unit : IsUnit vf := by + simpa only [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, not_not] using hv_not_mem + obtain ⟨w, hw⟩ := hv_unit + have hinv : ((((w⁻¹ : (V.toSubring)ˣ) : V.toSubring) : K)) = + (MvPolynomial.aeval t f)⁻¹ := by + rw [← hvf, ← hw] + change (↑(Units.map V.toSubring.subtype.toMonoidHom w⁻¹) : K) = + (↑(Units.map V.toSubring.subtype.toMonoidHom w) : K)⁻¹ + rw [map_inv] + exact Units.val_inv_eq_inv_val _ + rw [← hinv] + exact ((w⁻¹ : (V.toSubring)ˣ) : V.toSubring).property + have hEV : ∀ z : E, (z : K) ∈ V.toSubring := by + rintro ⟨z, hz⟩ + change z ∈ V.toSubring + obtain ⟨r, q, hz⟩ := (IntermediateField.mem_adjoin_range_iff k t z).mp hz + rw [hz, div_eq_mul_inv] + exact V.toSubring.mul_mem (eval_mem r) (inv_eval_mem q) + refine ⟨E, hEV, ?_⟩ + letI : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + let ρ : A →+* ResidueField V.toSubring := (residue V.toSubring).comp AV + have hpker : ∀ x ∈ p, ρ x = 0 := by + intro x hx + exact (IsLocalRing.residue_eq_zero_iff _).mpr ((hp x).mpr hx) + let ρbar : (A ⧸ p) →+* ResidueField V.toSubring := Ideal.Quotient.lift p ρ hpker + let et : Fin s → E := fun i ↦ + ⟨t i, IntermediateField.subset_adjoin k (Set.range t) ⟨i, rfl⟩⟩ + have halgebraMap_et (i : Fin s) : + algebraMap E (ResidueField V.toSubring) (et i) = ρ (a i) := by + rfl + haveI hkEV : IsScalarTower k E V.toSubring := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + haveI hEVκ : IsScalarTower E V.toSubring (ResidueField V.toSubring) := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + haveI hkEκ : IsScalarTower k E (ResidueField V.toSubring) := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + let ρbarK : (A ⧸ p) →ₐ[k] ResidueField V.toSubring := + { toRingHom := ρbar + commutes' := fun c ↦ by + change ρbar (Ideal.Quotient.mk p (algebraMap k A c)) = _ + rw [Ideal.Quotient.lift_mk] + rfl } + let P := MvPolynomial (Fin s) k + letI : Algebra P (A ⧸ p) := g.toRingHom.toAlgebra + letI : Algebra P E := (MvPolynomial.aeval et).toRingHom.toAlgebra + letI : Algebra P (ResidueField V.toSubring) := + ((algebraMap E (ResidueField V.toSubring)).comp + (MvPolynomial.aeval et).toRingHom).toAlgebra + haveI hPEκ : IsScalarTower P E (ResidueField V.toSubring) := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + have hpoly : ρbarK.comp g = + (IsScalarTower.toAlgHom k E (ResidueField V.toSubring)).comp + (MvPolynomial.aeval et) := by + ext i + simp only [AlgHom.comp_apply, MvPolynomial.aeval_X] + change ρbar (g (MvPolynomial.X i)) = algebraMap E (ResidueField V.toSubring) (et i) + rw [show g (MvPolynomial.X i) = Ideal.Quotient.mk p (a i) from (ha i).symm, + Ideal.Quotient.lift_mk] + exact (halgebraMap_et i).symm + let ρbarP : (A ⧸ p) →ₐ[P] ResidueField V.toSubring := + { toRingHom := ρbar + commutes' := fun f ↦ by + exact congrArg (fun e : MvPolynomial (Fin s) k →ₐ[k] + ResidueField V.toSubring ↦ e f) hpoly } + letI hPB : Module.Finite P (A ⧸ p) := hgfin + have residue_integral (x : A) : IsIntegral E (ρ x) := by + have hx : IsIntegral P (Ideal.Quotient.mk p x) := IsIntegral.of_finite P _ + have hx' : IsIntegral E (ρbarP (Ideal.Quotient.mk p x)) := + (hx.map ρbarP).tower_top + convert hx' using 1 + change ρbar (Ideal.Quotient.mk p x) = ρ x + exact Ideal.Quotient.lift_mk p ρ hpker + obtain ⟨S, hS⟩ := (inferInstance : Algebra.FiniteType k A).out + let gen : S → ResidueField V.toSubring := fun x ↦ ρ x.1 + let L : IntermediateField E (ResidueField V.toSubring) := + IntermediateField.adjoin E (Set.range gen) + have rho_mem (x : A) : ρ x ∈ L := by + have hx : x ∈ Algebra.adjoin k (S : Set A) := by + rw [hS] + trivial + induction hx using Algebra.adjoin_induction with + | mem x hx => + exact IntermediateField.subset_adjoin E (Set.range gen) + ⟨⟨x, hx⟩, rfl⟩ + | algebraMap c => + change ρ (algebraMap k A c) ∈ L + rw [show ρ (algebraMap k A c) = + algebraMap k (ResidueField V.toSubring) c from rfl, + IsScalarTower.algebraMap_apply k E (ResidueField V.toSubring)] + exact L.algebraMap_mem _ + | add x y _ _ hx hy => exact L.add_mem hx hy + | mul x y _ _ hx hy => exact L.mul_mem hx hy + have hL : L = ⊤ := by + apply top_unique + intro z _ + obtain ⟨x, y, hy, hz⟩ := hsurj z + rw [hz] + exact L.div_mem (rho_mem x) (rho_mem y) + have gen_integral (z : ResidueField V.toSubring) (hz : z ∈ Set.range gen) : + IsIntegral E z := by + obtain ⟨x, rfl⟩ := hz + exact residue_integral x.1 + letI hfiniteL : Module.Finite E L := + IntermediateField.finiteDimensional_adjoin gen_integral + let e : L ≃ₐ[E] ResidueField V.toSubring := + (IntermediateField.equivOfEq hL).trans IntermediateField.topEquiv + exact Module.Finite.equiv e.toLinearEquiv + + +end Stafford38.Geometry.DivisorialVisibleFrameStage5 diff --git a/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStageAssembly.lean b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStageAssembly.lean new file mode 100644 index 0000000000..494bcef6aa --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/DivisorialVisibleFrameStageAssembly.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameCore +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage2 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage4 +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStage5 + +open IsLocalRing Polynomial +open Stafford38.Geometry.NormalizationHeightOne + +noncomputable section + +universe u v + +namespace Stafford38.Geometry.LaneC + +theorem stage2_of_verified : Stage2Obligation.{u} := by + intro k K _ _ _ _ r y i hgen hx + exact DivisorialVisibleFrameStage2.stage2_exists_chart_normalization y i hgen hx + +theorem stage4_of_verified : Stage4Obligation.{u, v} := by + intro k K _ _ _ A p _ V _ _ _ hAV hp hsurj _ι c hc hint + exact DivisorialVisibleFrameStage4.stage4_residueField_isAlgebraic_of_isIntegral + A p V hAV hp hsurj c hc hint + +theorem stage5_of_verified : Stage5Obligation.{u} := by + intro k K _ _ _ A hAft p _ V _ hAV hp hsurj + obtain ⟨E, hEV, hfin⟩ := + DivisorialVisibleFrameStage5.stage5_exists_coefficientField A p V hAV hp hsurj + refine ⟨E, hEV, ?_⟩ + let scratch : Algebra E V.toSubring := + (DivisorialVisibleFrameStage5.coeffHom E V hEV).toAlgebra + let lane : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + have heq : scratch = lane := by + apply Algebra.algebra_ext + intro z + rfl + cases heq + exact hfin + +theorem divisorialVisibleFrameExistence : DivisorialVisibleFrameExistence.{u} := by + intro k K _ _ _ _ r y i hgen hx + let S2 := assembly_scaffold_of_obligations stage2_of_verified + stage4_of_verified stage5_of_verified + obtain ⟨j, s, A, hs, hjs, hnormA, hyA, hAft, hAic, hAfr, haint, hinvA⟩ := + S2.stage2 y i hgen hx + letI : Algebra.FiniteType k A := hAft + letI : IsNoetherianRing A := Algebra.FiniteType.isNoetherianRing k A + letI : IsFractionRing A K := hAfr + letI : IsIntegrallyClosedIn A K := hAic + letI : IsIntegrallyClosed A := + (isIntegrallyClosed_iff_isIntegrallyClosedIn K).mpr hAic + let xA : A := ⟨y i, hyA⟩ + have hy0 : y i ≠ 0 := by + intro h + exact hx (h ▸ isAlgebraic_zero) + have hxA0 : xA ≠ 0 := by + intro h + apply hy0 + exact congrArg Subtype.val h + have hxAu : ¬ IsUnit xA := by + intro hu + obtain ⟨z, hz⟩ := (isUnit_iff_exists_inv.mp hu) + have hzK : (y i) * (z : K) = 1 := by + exact congrArg Subtype.val hz + have hzInv : (y i)⁻¹ = (z : K) := by + simpa using congrArg Inv.inv (eq_inv_of_mul_eq_one_left hzK) + apply hinvA + rw [hzInv] + exact z.property + obtain ⟨p, hp, hpheight, hxp, hplace⟩ := + stage3_exists_height_one_prime_valuation A xA hxA0 hxAu + letI : p.IsPrime := hp + let V : ValuationSubring K := placeValuationSubring A p hplace + letI : IsLocalization.AtPrime (placeSubalgebra A p) p := by + unfold placeSubalgebra + infer_instance + have hVdvr : IsDiscreteValuationRing V.toSubring := by + change IsDiscreteValuationRing (placeSubalgebra A p).toSubring + exact isDiscreteValuationRing_of_isLocalization_atPrime p hpheight + (placeSubalgebra A p) + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + have hAV : ∀ a : A, (a : K) ∈ V.toSubring := + fun a => ofField_mem_algebraMap_v A p hplace a + have hpV : ∀ a : A, (⟨a, hAV a⟩ : V.toSubring) ∈ + maximalIdeal V.toSubring ↔ a ∈ p := + fun a => ofField_mem_maximalIdeal_iff_v A p hplace a + have hsurj : ∀ z : ResidueField V.toSubring, ∃ (a b : A), b ∉ p ∧ + z = residue V.toSubring ⟨a, hAV a⟩ / + residue V.toSubring ⟨b, hAV b⟩ := + fun z => ofField_residue_surjective_v A p hplace z + have hxV : y i ∈ V.toSubring := by + exact ofField_mem_algebraMap_v A p hplace xA + have hxm : (⟨y i, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring := by + apply (hpV xA).2 + exact hxp + obtain ⟨E, hEV, hEfin⟩ := S2.stage5 A p V hAV hpV hsurj + letI : Algebra E V.toSubring := (coeffHom E V hEV).toAlgebra + have htrans : Transcendental E (y i) := + stage6_transcendental_of_mem_maximalIdeal E V hEV (y i) hy0 hxV hxm + have hk : ∀ c : k, algebraMap k K c ∈ (placeSubalgebra A p).toSubring := + fun c => by + change algebraMap k K c ∈ V.toSubring + have heq : algebraMap k K c = + (algebraMap (↥A) K) (algebraMap k A c) := + (IsScalarTower.algebraMap_apply k A K c).symm + rw [heq] + exact hAV (algebraMap k A c) + let cod : Algebra k V.toSubring := + ((algebraMap k K).codRestrict _ hk).toAlgebra + letI : Algebra k V.toSubring := cod + have hkaehlerCod : Module.Finite V.toSubring + (Ω[V.toSubring⁄k]) := by + exact stage7_kaehler_finite_ofField A p hk + let ground : Algebra k V.toSubring := (groundHom E V hEV).toAlgebra + have hcod_ground : cod = ground := by + apply Algebra.algebra_ext + intro c + apply Subtype.ext + rfl + letI : Algebra k V.toSubring := ground + letI : IsScalarTower k V.toSubring K := + IsScalarTower.of_algebraMap_eq fun c => by + change algebraMap k K c = algebraMap k K c + rfl + have hkaehler : Module.Finite V.toSubring + (Ω[V.toSubring⁄k]) := by + cases hcod_ground + exact hkaehlerCod + let c : Fin (r + 1) → V.toSubring := fun a => + ⟨(Fin.cases 1 y a : K) * s, + hAV ⟨(Fin.cases 1 y a : K) * s, hnormA a⟩⟩ + have hc : ∀ a, (c a : K) = (Fin.cases 1 y a : K) * s := + fun a => rfl + have hcj : c j = 1 := by + apply Subtype.ext + exact hjs + have halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range fun a => residue V.toSubring (c a)) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring) := by + let c' : (Fin (r + 1) ⊕ Unit) → K := fun a => + match a with + | Sum.inl b => (Fin.cases 1 y b : K) * s + | Sum.inr _ => y i + have hset : Set.range c' = + Set.range (fun a : Fin (r + 1) => (Fin.cases 1 y a : K) * s) ∪ {y i} := by + ext z + constructor + · rintro ⟨a, rfl⟩ + cases a with + | inl b => exact Or.inl ⟨b, rfl⟩ + | inr u => exact Or.inr (Set.mem_singleton _) + · intro hz + rcases hz with ⟨b, rfl⟩ | rfl + · exact ⟨Sum.inl b, rfl⟩ + · exact ⟨Sum.inr (), rfl⟩ + have hBig : Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range fun a => + residue V.toSubring ⟨c' a, by + cases a with + | inl b => exact hAV ⟨c' (Sum.inl b), hnormA b⟩ + | inr _ => exact hAV xA⟩) : + IntermediateField k (ResidueField V.toSubring)) + (ResidueField V.toSubring) := by + apply S2.stage4 A p V hAV hpV hsurj c' + · intro a + cases a with + | inl b => exact hnormA b + | inr _ => exact hyA + · intro a + rw [hset] + exact haint a + have hyres : residue V.toSubring (⟨y i, hxV⟩ : V.toSubring) = 0 := + (IsLocalRing.residue_eq_zero_iff _).2 hxm + have hEq : IntermediateField.adjoin k (Set.range fun a => + residue V.toSubring ⟨c' a, by + cases a with + | inl b => exact hAV ⟨c' (Sum.inl b), hnormA b⟩ + | inr _ => exact hAV xA⟩) = + IntermediateField.adjoin k (Set.range fun a => residue V.toSubring (c a)) := by + apply le_antisymm + · apply IntermediateField.adjoin_le_iff.mpr + rintro z ⟨a, rfl⟩ + cases a with + | inl b => exact IntermediateField.subset_adjoin k _ ⟨b, rfl⟩ + | inr _ => + change residue V.toSubring (⟨y i, hxV⟩ : V.toSubring) ∈ + (IntermediateField.adjoin k + (Set.range fun a => residue V.toSubring (c a))) + rw [hyres] + exact (IntermediateField.adjoin k + (Set.range fun a => residue V.toSubring (c a))).zero_mem + · apply IntermediateField.adjoin_le_iff.mpr + rintro z ⟨b, rfl⟩ + exact IntermediateField.subset_adjoin k _ ⟨Sum.inl b, rfl⟩ + rw [← hEq] + exact hBig + refine ⟨E, V, hEV, hVdvr, hxV, htrans, hxm, hEfin, hkaehler, ?_⟩ + intro s' q hq hq1 hq0 + by_cases hj0 : j = 0 + · obtain ⟨j', hj'⟩ := hq1 + exfalso + have hsone : s = 1 := by simpa [hj0] using hjs + have hprod : ∀ a, q a = q 0 * c a := by + intro a + apply Subtype.ext + change (q a : K) = (q 0 : K) * (c a : K) + rw [hq a, hq 0, hc a] + simp [hsone] + have hq0res : residue V.toSubring (q 0) = 0 := by + by_contra hnz + exact hq0 ((residue_ne_zero_iff_isUnit _).1 hnz) + have hqjres : residue V.toSubring (q j') = 0 := by + rw [hprod j', map_mul, hq0res, zero_mul] + have hqjunit : IsUnit (q j') := by rw [hj']; exact isUnit_one + exact ((residue_ne_zero_iff_isUnit _).2 hqjunit) hqjres + · exact DivisorialVisibleFrameStage4.stage4'_isAlgebraic_of_normalized_column + V y j hj0 s c hc hcj halg + s' q hq hq1 hq0 + +end Stafford38.Geometry.LaneC diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ExactDivisorialVisibleFrameExistence.lean b/LeanPool/Stafford38/Stafford38/Geometry/ExactDivisorialVisibleFrameExistence.lean new file mode 100644 index 0000000000..57e8d72009 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ExactDivisorialVisibleFrameExistence.lean @@ -0,0 +1,425 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialVisibleFrameStageAssembly +import LeanPool.Stafford38.Stafford38.Geometry.ExactVisibleDivisorFrameInterface +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerDVRVisibility +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import LeanPool.Stafford38.Stafford38.Geometry.RelativeRetainedBoundaryPlace + +namespace Stafford38.Geometry.ExactDivisorialVisibleFrameExistence + +open IsLocalRing Polynomial +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveOrder +open Stafford38.Geometry.DivisorTangentLattice +open Stafford38.Geometry.KaehlerDVRVisibility +open Stafford38.Geometry.ProjectiveDivisorOrderGap +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedDVR +open Stafford38.Geometry.ExactVisibleDivisorFrameInterface +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence + +noncomputable section + + +universe u + +open Stafford38.Geometry.AffineComponentCoordinateSplit + +/-- The affine coordinates generate the function field of a prime component. +This is the exact generation hypothesis consumed by the lane-C stage +assembly. -/ +theorem componentCoordinate_adjoin_eq_top + {k : Type u} [Field k] {m : ℕ} + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) : + IntermediateField.adjoin k (Set.range (componentCoordinate P)) = ⊤ := by + let R := MvPolynomial (Fin m) k ⧸ P.asIdeal + let K := FractionRing R + let L : IntermediateField k K := + IntermediateField.adjoin k (Set.range (componentCoordinate P)) + have hpoly (p : MvPolynomial (Fin m) k) : + algebraMap R K (Ideal.Quotient.mk P.asIdeal p) ∈ L := by + induction p using MvPolynomial.induction_on with + | C c => + rw [← MvPolynomial.algebraMap_eq, + Ideal.Quotient.mk_algebraMap, + ← IsScalarTower.algebraMap_apply k R K] + exact L.algebraMap_mem c + | add p q hp hq => + rw [map_add, map_add] + exact L.add_mem hp hq + | mul_X p i hp => + rw [map_mul, map_mul] + apply L.mul_mem hp + exact IntermediateField.subset_adjoin k _ ⟨i, rfl⟩ + have hquot (z : R) : algebraMap R K z ∈ L := by + refine Quotient.inductionOn z ?_ + intro p + exact hpoly p + apply top_unique + intro z _ + obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective R z + rw [← hab] + exact L.div_mem (hquot a) (hquot b) + +theorem coordinateZeroLocal_maximalIdeal_eq_span (E : Type u) [Field E] : + maximalIdeal (CoordinateZeroLocalRing E) = + Ideal.span + {algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X} := by + calc + maximalIdeal (CoordinateZeroLocalRing E) = + Ideal.map (algebraMap (Polynomial E) (CoordinateZeroLocalRing E)) + (coordinateZeroPrime E) := + (IsLocalization.AtPrime.map_eq_maximalIdeal + (coordinateZeroPrime E) (CoordinateZeroLocalRing E)).symm + _ = Ideal.map (algebraMap (Polynomial E) (CoordinateZeroLocalRing E)) + (Ideal.span {Polynomial.X}) := rfl + _ = Ideal.span + {algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X} := by + rw [Ideal.map_span, Set.image_singleton] + +/-- The coordinate-zero local ring maps to a valuation ring that contains +the coefficient field and the selected element in its maximal ideal. -/ +def coordinateZeroLocalFactor + {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) + (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (x : K) (hxV : x ∈ V.toSubring) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) : + CoordinateZeroLocalRing E →+* V.toSubring := by + let c : E →+* V.toSubring := + Stafford38.Geometry.LaneC.coeffHom E V hEV + let xV : V.toSubring := ⟨x, hxV⟩ + let g : Polynomial E →+* V.toSubring := Polynomial.eval₂RingHom c xV + exact IsLocalization.lift (S := CoordinateZeroLocalRing E) + (M := (coordinateZeroPrime E).primeCompl) (g := g) fun p ↦ by + have hp0 : (p : Polynomial E).coeff 0 ≠ 0 := by + intro hp0 + apply p.property + change (p : Polynomial E) ∈ Ideal.span {Polynomial.X} + rw [Ideal.mem_span_singleton, Polynomial.X_dvd_iff] + exact hp0 + have hcunit : IsUnit (c ((p : Polynomial E).coeff 0)) := + (isUnit_iff_ne_zero.mpr hp0).map c + apply (residue_ne_zero_iff_isUnit (g (p : Polynomial E))).mp + have hresx : residue V.toSubring xV = 0 := + (residue_eq_zero_iff xV).mpr hxm + have hresconst : residue V.toSubring + (c ((p : Polynomial E).coeff 0)) ≠ 0 := + (residue_ne_zero_iff_isUnit + (c ((p : Polynomial E).coeff 0))).mpr hcunit + have hdecomp := Polynomial.X_mul_divX_add (p : Polynomial E) + have heval : residue V.toSubring (g (p : Polynomial E)) = + residue V.toSubring (c ((p : Polynomial E).coeff 0)) := by + calc + residue V.toSubring (g (p : Polynomial E)) = + residue V.toSubring + (g (Polynomial.X * Polynomial.divX (p : Polynomial E) + + Polynomial.C ((p : Polynomial E).coeff 0))) := + congrArg (fun z ↦ residue V.toSubring (g z)) hdecomp.symm + _ = residue V.toSubring (c ((p : Polynomial E).coeff 0)) := by + rw [map_add, map_mul] + change residue V.toSubring (Polynomial.eval₂ c xV Polynomial.X) * + residue V.toSubring + (Polynomial.eval₂ c xV (Polynomial.divX (p : Polynomial E))) + + residue V.toSubring + (Polynomial.eval₂ c xV + (Polynomial.C ((p : Polynomial E).coeff 0))) = _ + rw [Polynomial.eval₂_X, Polynomial.eval₂_C, hresx, + zero_mul, zero_add] + rw [heval] + exact hresconst + +theorem coordinateZeroLocalFactor_map_X + {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) + (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (x : K) (hxV : x ∈ V.toSubring) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) : + coordinateZeroLocalFactor E V hEV x hxV hxm + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X) = + (⟨x, hxV⟩ : V.toSubring) := by + rw [coordinateZeroLocalFactor, IsLocalization.lift_eq] + exact Polynomial.eval₂_X _ _ + +theorem coordinateZeroLocalFactor_isLocal + {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) + (V : ValuationSubring K) [IsLocalRing V.toSubring] + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (x : K) (hxV : x ∈ V.toSubring) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) : + IsLocalHom (coordinateZeroLocalFactor E V hEV x hxV hxm) := by + let f := coordinateZeroLocalFactor E V hEV x hxV hxm + apply (IsLocalRing.local_hom_TFAE f).out 3 0 |>.mp + intro z hz + rw [coordinateZeroLocal_maximalIdeal_eq_span, + Ideal.mem_span_singleton] at hz + obtain ⟨a, rfl⟩ := hz + change f + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X * a) ∈ + maximalIdeal V.toSubring + rw [map_mul, coordinateZeroLocalFactor_map_X E] + exact Ideal.mul_mem_right _ _ hxm + +theorem coordinateZeroLocalFactor_residue_finite + {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) (V : ValuationSubring K) + [IsLocalRing V.toSubring] + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (x : K) (hxV : x ∈ V.toSubring) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) + (hfinite : + letI : Algebra E V.toSubring := + (Stafford38.Geometry.LaneC.coeffHom E V hEV).toAlgebra + Module.Finite E (ResidueField V.toSubring)) : + let f := coordinateZeroLocalFactor E V hEV x hxV hxm + let hf : IsLocalHom f := + coordinateZeroLocalFactor_isLocal E V hEV x hxV hxm + ResidueExtensionFinite f hf := by + let f := coordinateZeroLocalFactor E V hEV x hxV hxm + let hf : IsLocalHom f := + coordinateZeroLocalFactor_isLocal E V hEV x hxV hxm + letI : Algebra E V.toSubring := + (Stafford38.Geometry.LaneC.coeffHom E V hEV).toAlgebra + letI : Module.Finite E (ResidueField V.toSubring) := hfinite + letI : Algebra (CoordinateZeroLocalRing E) V.toSubring := f.toAlgebra + letI : IsLocalHom (algebraMap (CoordinateZeroLocalRing E) V.toSubring) := hf + let e₁ : E ≃+* ResidueField (CoordinateZeroLocalRing E) := + (coordinateResidueEquiv E).symm + let e₂ : ResidueField V.toSubring ≃+* ResidueField V.toSubring := + RingEquiv.refl _ + have he₁ (z : E) : e₁ z = + algebraMap E (ResidueField (CoordinateZeroLocalRing E)) z := by + apply (coordinateResidueEquiv E).injective + simp only [e₁, RingEquiv.apply_symm_apply, + coordinateResidueEquiv_algebraMap] + have hcompat : + (algebraMap (ResidueField (CoordinateZeroLocalRing E)) + (ResidueField V.toSubring)).comp e₁.toRingHom = + e₂.toRingHom.comp (algebraMap E (ResidueField V.toSubring)) := by + ext z + rw [RingHom.comp_apply, RingHom.comp_apply] + change algebraMap (ResidueField (CoordinateZeroLocalRing E)) + (ResidueField V.toSubring) (e₁ z) = + e₂ (algebraMap E (ResidueField V.toSubring) z) + rw [he₁] + change residue V.toSubring + (f (algebraMap E (CoordinateZeroLocalRing E) z)) = + residue V.toSubring + (Stafford38.Geometry.LaneC.coeffHom E V hEV z) + dsimp only [f] + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (CoordinateZeroLocalRing E) z] + rw [coordinateZeroLocalFactor, IsLocalization.lift_eq] + simp + change Module.Finite (ResidueField (CoordinateZeroLocalRing E)) + (ResidueField V.toSubring) + exact Module.Finite.of_equiv_equiv e₁ e₂ hcompat + +/-- Package the particular DVR produced by the stage assembly as retained +boundary data, without replacing its parameter by a uniformizer. -/ +def retainedDataOfValuation + {k K : Type u} [Field k] [Field K] [Algebra k K] + (E : IntermediateField k K) (V : ValuationSubring K) + (hEV : ∀ z : E, (z : K) ∈ V.toSubring) + (hVdvr : IsDiscreteValuationRing V.toSubring) + (x : K) (hxV : x ∈ V.toSubring) + (htrans : Transcendental E x) + (hxm : (⟨x, hxV⟩ : V.toSubring) ∈ maximalIdeal V.toSubring) + (hfinite : + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + letI : Algebra E V.toSubring := + (Stafford38.Geometry.LaneC.coeffHom E V hEV).toAlgebra + Module.Finite E (ResidueField V.toSubring)) : Data k K x := by + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + let xV : V.toSubring := ⟨x, hxV⟩ + let f : CoordinateZeroLocalRing E →+* V.toSubring := + coordinateZeroLocalFactor E V hEV x hxV hxm + let hf : IsLocalHom f := + coordinateZeroLocalFactor_isLocal E V hEV x hxV hxm + let ambient : Algebra (CoordinateZeroLocalRing E) K := + (V.toSubring.subtype.comp f).toAlgebra + letI : Algebra (CoordinateZeroLocalRing E) K := ambient + have tower : IsScalarTower E (CoordinateZeroLocalRing E) K := by + apply IsScalarTower.of_algebraMap_eq + intro z + change (z : K) = + ((f (algebraMap E (CoordinateZeroLocalRing E) z) : V.toSubring) : K) + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (CoordinateZeroLocalRing E) z] + dsimp only [f] + rw [coordinateZeroLocalFactor, IsLocalization.lift_eq] + simp [Stafford38.Geometry.LaneC.coeffHom] + have coordinate_eq : + algebraMap (CoordinateZeroLocalRing E) K + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X) = x := by + change ((f + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X) : + V.toSubring) : K) = x + rw [coordinateZeroLocalFactor_map_X E] + have xV_ne : xV ≠ 0 := by + intro hx0 + apply htrans + have hx0K : x = 0 := congrArg Subtype.val hx0 + exact hx0K ▸ isAlgebraic_zero + have xV_nonunit : ¬ IsUnit xV := by + rw [← mem_nonunits_iff, ← IsLocalRing.mem_maximalIdeal] + exact hxm + have hresfinite : ResidueExtensionFinite f hf := + coordinateZeroLocalFactor_residue_finite E V hEV x hxV hxm hfinite + let place : RetainedDVRPlace (CoordinateZeroLocalRing E) (L := K) + (algebraMap (Polynomial E) (CoordinateZeroLocalRing E) Polynomial.X) := + { valuation := V + isDiscrete := hVdvr + parameter := xV + parameter_eq := coordinate_eq.symm + parameter_ne := xV_ne + parameter_nonunit := xV_nonunit + factor := f + factor_commutes := rfl + factor_isLocal := hf + residue_finite := hresfinite } + exact + { coefficientField := E + coordinate_transcendental := htrans + ambientAlgebra := ambient + coefficientTower := tower + coordinate_eq := coordinate_eq + place := place } + +/-- The stage-assembly place, its normalized projective column, and the +Kähler image together discharge the exact residual. The element `t` below +is a separately chosen DVR uniformizer; the retained parameter remains the +selected affine coordinate and may have higher order. -/ +theorem exactDivisorialVisibleFrameExistence : + ExactDivisorialVisibleFrameExistence.{u} := by + intro k _ _ _ n N d hn hdisjoint P hP htrans + let i : Fin (n + 1) := ⟨0, Nat.zero_lt_succ n⟩ + let K := ComponentFractionField P + obtain ⟨E, V, hEV, hVdvr, hxV, htransE, hxm, hEfin, hkaehler, halgAll⟩ := + Stafford38.Geometry.LaneC.divisorialVisibleFrameExistence + k K (n + 1) (componentCoordinate P) i + (componentCoordinate_adjoin_eq_top P) htrans + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + letI : Algebra E V.toSubring := + (Stafford38.Geometry.LaneC.coeffHom E V hEV).toAlgebra + letI : Algebra k V.toSubring := + (Stafford38.Geometry.LaneC.groundHom E V hEV).toAlgebra + letI : Algebra V.toSubring K := V.toSubring.subtype.toAlgebra + letI : IsScalarTower k V.toSubring K := + IsScalarTower.of_algebraMap_eq fun c => by + change algebraMap k K c = (algebraMap k E c : K) + exact IsScalarTower.algebraMap_apply k E K c + letI : Module.Finite V.toSubring (Ω[V.toSubring⁄k]) := hkaehler + let W : Data k K (componentCoordinate P i) := + retainedDataOfValuation E V hEV hVdvr (componentCoordinate P i) hxV + htransE hxm hEfin + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + obtain ⟨chart, qraw, scale, hscale, hchartRaw, hqraw⟩ := + exists_normalized_projective_lift V (componentProjectivePoint P) + ⟨0, by simp [componentProjectivePoint]⟩ + let q : Fin (n + 1 + 1) → V.toSubring := fun a => + ⟨qraw a, (qraw a).property⟩ + have hchart : q chart = 1 := by + apply Subtype.ext + exact congrArg Subtype.val hchartRaw + have hq : ∀ a, (q a : K) = scale * componentProjectivePoint P a := by + intro a + exact hqraw a + have hq0 : q 0 ≠ 0 := by + intro hzero + apply hscale + have h := hq 0 + rw [hzero] at h + simpa [componentProjectivePoint] using h.symm + let xV : V.toSubring := ⟨componentCoordinate P i, hxV⟩ + have hratioV : q (Fin.succ i) = q 0 * xV := by + apply Subtype.ext + change (q (Fin.succ i) : K) = (q 0 : K) * componentCoordinate P i + rw [hq, hq] + simp [componentProjectivePoint] + have hBP : + reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N) ≤ P.asIdeal := + hP.1.2 + have hq0nonunit : ¬ IsUnit (q 0) := + normalizedComponentProjectivePoint_zero_nonunit + (canonicalRightIdeal (presentedCoordinate k n) d N) i hdisjoint P hBP + W q scale hq + have halg := halgAll scale q hq ⟨chart, hchart⟩ hq0nonunit + have hchart_ne : chart ≠ 0 := by + intro hzero + apply hq0nonunit + rw [← hzero, hchart] + exact isUnit_one + obtain ⟨j₀, rfl⟩ := Fin.exists_succ_eq_of_ne_zero hchart_ne + obtain ⟨t, ht⟩ := IsDiscreteValuationRing.exists_irreducible V.toSubring + have hq0max : q 0 ∈ maximalIdeal V.toSubring := by + apply (IsLocalRing.mem_maximalIdeal (q 0)).2 + exact mem_nonunits_iff.mpr hq0nonunit + have hxV_ne : xV ≠ 0 := by + intro hx0 + apply htransE + have hx0K : componentCoordinate P i = 0 := congrArg Subtype.val hx0 + exact hx0K ▸ isAlgebraic_zero + obtain ⟨a, e, b, u₀, ur, u₁, ha, he, hb, hab, + hq0factor, hparameterFactor, hu₁, hq1factor⟩ := + exists_uniformizer_strict_orderGap t ht (q 0) xV + (q (Fin.succ i)) hq0 hxV_ne hq0max hxm hratioV + let Q : Fin (n + 1) → V.toSubring := fun j => q (Fin.succ j) + have hQj₀ : Q j₀ = 1 := hchart + have hq0frame : q 0 = t ^ a * (u₀ : V.toSubring) := by + simpa [mul_comm] using hq0factor + have hq1frame : + q (Fin.succ i) = t ^ (a + e) * (u₁ : V.toSubring) := by + simpa [hb, mul_comm] using hq1factor + obtain ⟨D, hD0, hD1, hDt, hDu, hDw, hDQ, hDa, hDe, hDj, hDW⟩ := + exists_visibleDivisorFrame_of_kaehler_image + (k := k) (F := K) (q 0) (q (Fin.succ i)) t + (u₀ : V.toSubring) (u₁ : V.toSubring) Q a e j₀ + ht.maximalIdeal_eq ht.ne_zero u₀.isUnit + (Nat.one_le_iff_ne_zero.mpr ha.ne') + (Nat.one_le_iff_ne_zero.mpr he.ne') hq0frame hq1frame hQj₀ halg + refine ⟨W, Fin.succ j₀, q, scale, hscale, hchart, hq0, hq, ?_, ?_⟩ + · apply Subtype.ext + have hv := congrArg Subtype.val hratioV + change (q (Fin.succ ⟨0, Nat.zero_lt_succ n⟩) : K) = + (q 0 : K) * componentCoordinate P ⟨0, Nat.zero_lt_succ n⟩ at hv + calc + (q (Fin.succ ⟨0, Nat.zero_lt_succ n⟩) : K) = + (q 0 : K) * componentCoordinate P ⟨0, Nat.zero_lt_succ n⟩ := hv + _ = (q 0 : K) * (W.place.parameter : K) := by + rw [W.parameter_eq_coordinate] + · exact ⟨D, hD0, hD1, fun j => by rw [hDQ]⟩ + +/-- Trust-zero production of the exact higher-dimensional visible-frame +input used by the terminal lane-C consumer. -/ +theorem higherDimensionalCanonicalVisibleDivisorFrameProduction : + HigherDimensionalCanonicalVisibleDivisorFrameProduction.{u} := + higherDimensionalCanonicalVisibleDivisorFrameProduction_of_exactResidual + exactDivisorialVisibleFrameExistence + + +end + +end Stafford38.Geometry.ExactDivisorialVisibleFrameExistence diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ExactVisibleDivisorFrameInterface.lean b/LeanPool/Stafford38/Stafford38/Geometry/ExactVisibleDivisorFrameInterface.lean new file mode 100644 index 0000000000..547e955cc0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ExactVisibleDivisorFrameInterface.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction + +/-! +# Exact visible-divisor-frame interface + +A bare DVR, coefficient field, and residue-field finiteness do not by +themselves produce the retained `Data`, normalized projective column, and +`VisibleDivisorFrame` required by `HasVisibleDivisorFrame`. + +The repository already constructs the retained `Data` and the normalized +column, including the exact parameter identity. The first unsupported bridge +is therefore isolated as `HasCompatibleVisibleFrame`: a visible differential +frame on that same retained column. Its divisor parameter `D.t` is independent +of `W.place.parameter`: the former may be chosen as a genuine DVR uniformizer, +whereas the retained coordinate can have higher valuation after ramification. + +The exact producer is supplied separately by +`ExactDivisorialVisibleFrameExistence`. +-/ + +namespace Stafford38.Geometry.ExactVisibleDivisorFrameInterface + +open IsLocalRing +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.EulerSurjectivity +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CanonicalFiniteGradientProjectiveCoordinates +open Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveOrder +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.DivisorTangentLattice +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The exact missing datum after a retained place and normalized projective +column have been fixed: a visible differential frame on that same column. +Constructing it still requires a finite differential lattice containing the +unit and coordinate differentials and the explicit modulo-`D.t` inclusion +stored in `D.visible`. -/ +def HasCompatibleVisibleFrame + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + [CharZero k] + (W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + (Fin (m + 1) → W.place.valuation.toSubring) → Prop := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + exact fun q ↦ + ∃ D : VisibleDivisorFrame (V := V) + (KaehlerDifferential.D k (ComponentFractionField P)) (Fin m), + D.Q₀ = q 0 ∧ + D.Q₁ = q (Fin.succ ⟨0, hm⟩) ∧ + ∀ j, D.Q j = q (Fin.succ j) + +/-- Once the compatible frame is supplied, the retained data, common-scale +normalization, and exact parameter identity are exactly the fields required by +`HasVisibleDivisorFrame`. -/ +theorem hasVisibleDivisorFrame_of_compatible_normalized_column + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + (W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + q 0 ≠ 0 → + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter → + HasCompatibleVisibleFrame P hm W q → + HasVisibleDivisorFrame P hm := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + dsimp only + intro q scale hq0 hq hratio hframe + obtain ⟨D, hQ₀, hQ₁, hQ⟩ := hframe + exact ⟨W, q, scale, hq0, hq, hratio, D, hQ₀, hQ₁, hQ⟩ + +/-- Trust-zero prefix: the existing component theorem supplies the retained +`Data`, a normalized projective column, and the exact parameter identity. For +the very same witnesses, a compatible visible frame is sufficient and is the +only remaining premise. -/ +theorem exists_normalized_column_with_exact_frame_obligation + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + (hi : Transcendental k (componentCoordinate P ⟨0, hm⟩)) : + ∃ W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + ∃ (chart : Fin (m + 1)) (q : Fin (m + 1) → V) + (scale : ComponentFractionField P), + scale ≠ 0 ∧ q chart = 1 ∧ q 0 ≠ 0 ∧ + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter ∧ + (HasCompatibleVisibleFrame P hm W q → HasVisibleDivisorFrame P hm) := by + obtain ⟨W, chart, q, scale, hscale, hchart, hq0, hq, hratio⟩ := + exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace P ⟨0, hm⟩ hi + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + refine ⟨W, chart, q, scale, hscale, hchart, hq0, hq, hratio, ?_⟩ + exact hasVisibleDivisorFrame_of_compatible_normalized_column P hm W q scale + hq0 hq hratio + +/-- In the actual axis-avoidance context, the existing trust-zero prefix also +forces the normalized denominator to be a nonunit. Together with the retained +parameter's nonzero/nonunit fields, this supplies the order-theoretic inputs; +the compatible visible frame remains the first gap. -/ +theorem exists_axisAvoiding_normalized_column_with_exact_frame_obligation + [CharZero k] [IsAlgClosed k] + (I : RightIdeal (PresentedWeyl k m)) (hm : 0 < m) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (⟨0, hm⟩ : Fin m))} : Set (SymbolRing k m)))) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (hBP : reducedOrderBaseIdeal k I ≤ P.asIdeal) + (hi : Transcendental k (componentCoordinate P ⟨0, hm⟩)) : + ∃ W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + ∃ (chart : Fin (m + 1)) (q : Fin (m + 1) → V) + (scale : ComponentFractionField P), + scale ≠ 0 ∧ q chart = 1 ∧ q 0 ≠ 0 ∧ + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter ∧ + ¬ IsUnit (q 0) ∧ + (HasCompatibleVisibleFrame P hm W q → HasVisibleDivisorFrame P hm) := by + obtain ⟨W, chart, q, scale, hscale, hchart, hq0, hq, hratio⟩ := + exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace P ⟨0, hm⟩ hi + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + have hq0nonunit : ¬ IsUnit (q 0) := + normalizedComponentProjectivePoint_zero_nonunit + I ⟨0, hm⟩ hdisjoint P hBP W q scale hq + refine ⟨W, chart, q, scale, hscale, hchart, hq0, hq, hratio, + hq0nonunit, ?_⟩ + exact hasVisibleDivisorFrame_of_compatible_normalized_column P hm W q scale + hq0 hq hratio + +/-- The exact geometric witness missing after the trust-zero retained-place +prefix. Unlike `DivisorialVisibleFrameExistence`, this retains the same +`Data`, the normalized projective column, its exact parameter identity, and a +`VisibleDivisorFrame` attached to that column. -/ +def HasNormalizedCompatibleVisibleFrame + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) : Prop := + ∃ W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩), + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + ∃ (chart : Fin (m + 1)) (q : Fin (m + 1) → V) + (scale : ComponentFractionField P), + scale ≠ 0 ∧ q chart = 1 ∧ q 0 ≠ 0 ∧ + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) ∧ + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter ∧ + HasCompatibleVisibleFrame P hm W q + +/-- The exact witness above forgets to the pre-existing terminal input. -/ +theorem hasVisibleDivisorFrame_of_normalizedCompatibleVisibleFrame + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + (h : HasNormalizedCompatibleVisibleFrame P hm) : + HasVisibleDivisorFrame P hm := by + obtain ⟨W, chart, q, scale, hscale, hchart, hq0, hq, hratio, hframe⟩ := h + exact hasVisibleDivisorFrame_of_compatible_normalized_column P hm W q scale + hq0 hq hratio hframe + +/-- Repaired residual with exactly the ambient hypotheses of the actual lane C +consumer. The target-context hypotheses are retained because, in particular, +axis avoidance is needed to force the homogeneous denominator to vanish; the +component-only strengthening is false in general. -/ +def ExactDivisorialVisibleFrameExistence : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)), + 0 < n → + Disjoint + (orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) → + ∀ P : PrimeSpectrum (MvPolynomial (Fin (n + 1)) k), + P.asIdeal ∈ + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).minimalPrimes → + Transcendental k + (componentCoordinate P ⟨0, Nat.zero_lt_succ n⟩) → + HasNormalizedCompatibleVisibleFrame P (Nat.zero_lt_succ n) + +/-- The repaired residual has a direct, trust-zero adapter to the actual +higher-dimensional producer. -/ +theorem higherDimensionalCanonicalVisibleDivisorFrameProduction_of_exactResidual + (h : ExactDivisorialVisibleFrameExistence.{u}) : + HigherDimensionalCanonicalVisibleDivisorFrameProduction.{u} := by + intro k _ _ _ n N d hn hdisjoint P hP htrans + exact hasVisibleDivisorFrame_of_normalizedCompatibleVisibleFrame P + (Nat.zero_lt_succ n) (h k n N d hn hdisjoint P hP htrans) + + +end + +end Stafford38.Geometry.ExactVisibleDivisorFrameInterface diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FibreConicalVanishingIdeal.lean b/LeanPool/Stafford38/Stafford38/Geometry/FibreConicalVanishingIdeal.lean new file mode 100644 index 0000000000..bfb010fc1a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FibreConicalVanishingIdeal.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalContainment + +/-! +# Fibre-conical zero sets have homogeneous vanishing ideals +-/ + +namespace Stafford38.Geometry.FibreConicalVanishingIdeal + +open Stafford38.Characteristic +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.GeneralConormalContainment +open Stafford38.WeylFiltration + +noncomputable section + +variable {k : Type*} [Field k] [CharZero k] [IsAlgClosed k] {n : ℕ} + +/-- Stability under every nonzero scalar dilation in each cotangent fibre. -/ +def IsFibreConical (W : Set (PhaseVar n → k)) : Prop := + ∀ q ∈ W, ∀ a : k, a ≠ 0 → + Sum.elim (fun i => q (.inl i)) (fun i => a * q (.inr i)) ∈ W + +/-- The coefficient of fibre degree `d` on a fibre line is evaluation of the +`d`th order-weight homogeneous component. -/ +theorem coeff_fibreLinePolynomial_eq_eval_weightedHomogeneousComponent + (y ξ : Fin n → k) (g : SymbolRing k n) (d : ℕ) : + (fibreLinePolynomial y ξ g).coeff d = + MvPolynomial.eval (Sum.elim y ξ) + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) g d : + SymbolRing k n) := by + induction g using MvPolynomial.induction_on generalizing d with + | C c => + have hC : MvPolynomial.C c ∈ orderDecomposition (k := k) (n := n) 0 := + MvPolynomial.isWeightedHomogeneous_C (@orderWeight n) c + cases d with + | zero => + rw [DirectSum.decompose_of_mem_same + (orderDecomposition (k := k) (n := n)) hC] + simp + | succ d => + rw [DirectSum.decompose_of_mem_ne + (orderDecomposition (k := k) (n := n)) hC (Nat.succ_ne_zero d).symm] + simp + | add P Q hP hQ => + rw [fibreLinePolynomial_add, Polynomial.coeff_add, + DirectSum.decompose_add] + change _ = MvPolynomial.eval (Sum.elim y ξ) + ((DirectSum.decompose (orderDecomposition (k := k) (n := n)) P d : + SymbolRing k n) + + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) Q d : + SymbolRing k n)) + rw [MvPolynomial.eval_add, hP, hQ] + | mul_X P i hP => + rcases i with i | i + · have hX : MvPolynomial.X (Sum.inl i : PhaseVar n) ∈ + orderDecomposition (k := k) (n := n) 0 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) _ + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition (k := k) (n := n)) hX (Nat.zero_le d)] + simp [fibreLinePolynomial_mul, hP] + · have hX : MvPolynomial.X (Sum.inr i : PhaseVar n) ∈ + orderDecomposition (k := k) (n := n) 1 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) _ + cases d with + | zero => + rw [DirectSum.coe_decompose_mul_of_right_mem_of_not_le + (orderDecomposition (k := k) (n := n)) hX (by omega)] + simp [fibreLinePolynomial_mul] + | succ d => + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition (k := k) (n := n)) hX (by omega)] + rw [fibreLinePolynomial_mul, fibreLinePolynomial_X_fibre, ← mul_assoc, + Polynomial.coeff_mul_X, Polynomial.coeff_mul_C] + simp [hP] + +/-- Fibre-conicality makes the vanishing ideal homogeneous for fibre degree. -/ +theorem vanishingIdeal_isHomogeneous_of_isFibreConical + (W : Set (PhaseVar n → k)) (hW : IsFibreConical W) : + (MvPolynomial.vanishingIdeal k W).IsHomogeneous + (orderDecomposition (k := k) (n := n)) := by + intro d g hg + rw [MvPolynomial.mem_vanishingIdeal_iff] at hg ⊢ + intro q hq + let y : Fin n → k := fun i => q (.inl i) + let ξ : Fin n → k := fun i => q (.inr i) + have hline : fibreLinePolynomial y ξ g = 0 := by + apply Polynomial.eq_zero_of_infinite_isRoot + refine Set.Infinite.mono ?_ (Set.infinite_univ.sdiff (Set.finite_singleton 0)) + intro a ha + simp only [Set.mem_diff, Set.mem_univ, Set.mem_singleton_iff, true_and] at ha + change Polynomial.eval a (fibreLinePolynomial y ξ g) = 0 + rw [eval_fibreLinePolynomial] + exact hg _ (hW q hq a ha) + have hqeq : q = Sum.elim y ξ := by + funext i + cases i <;> rfl + rw [hqeq] + change MvPolynomial.eval (Sum.elim y ξ) + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) g d : + SymbolRing k n) = 0 + rw [← coeff_fibreLinePolynomial_eq_eval_weightedHomogeneousComponent y ξ g d, + hline, Polynomial.coeff_zero] + +end +end Stafford38.Geometry.FibreConicalVanishingIdeal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientBoundaryProducer.lean b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientBoundaryProducer.lean new file mode 100644 index 0000000000..75ccc103fb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientBoundaryProducer.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalAsymptoticLaurentProducer + +/-! +# A finite-gradient boundary producer + +The completed-boundary consumer does not need a comparison of the entire +Zariski tangent space with a chosen matrix of tangent columns. It needs only +one conormal covector. This file replaces that global comparison by an +explicit finite expression of the required covector as a linear combination +of differentials of equations in the scalar-extended affine ideal. + +This is the algebraic certificate naturally supplied at a smooth generic +point by a Jacobian/conormal calculation. It is strictly local to the one +annihilating row and is independently checkable coordinate by coordinate. +No normalization, projective closure, boundary divisor, or existence of such +a certificate is asserted here. +-/ + +namespace Stafford38.Geometry.FiniteGradientBoundaryProducer + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Geometry.PointwiseConormalContainment +open Stafford38.GeometryRetractionSpecialization +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +/-! ## The finite-gradient bridge -/ + +/-- A coordinate covector is conormal when its coordinates are an explicit +finite linear combination of gradients of equations in the ideal. This +avoids any equality or inclusion assertion about the whole tangent space. -/ +theorem coordinateCovector_mem_affineConormalSpace_of_finite_gradient + {m r : ℕ} + (I : Ideal (MvPolynomial (Fin m) K)) + (y xi : Fin m → K) + (equations : Fin r → I) + (coefficients : Fin r → K) + (hgradient : ∀ i, + xi i = ∑ j, coefficients j * differentialAt y (equations j).1 i) : + coordinateCovector xi ∈ affineConormalSpace y I := by + classical + rw [affineConormalSpace_eq_equationCovectorSpan] + let g := baseLinearCombination coefficients (fun j ↦ (equations j).1) + have hg : g ∈ I := by + dsimp only [g, baseLinearCombination] + apply Ideal.sum_mem + intro j hj + exact I.mul_mem_left (MvPolynomial.C (coefficients j)) (equations j).2 + let gI : I := ⟨g, hg⟩ + have hxi : xi = fun i ↦ differentialAt y g i := by + funext i + rw [hgradient, differentialAt_baseLinearCombination] + have heq : coordinateCovector xi = differentialCovector y g := by + apply LinearMap.ext + intro v + simp only [coordinateCovector_apply, differentialCovector_apply, hxi] + rw [heq] + apply Submodule.subset_span + refine ⟨gI, ?_⟩ + rfl + +/-! ## Corrected local boundary interface -/ + +/-- A completed projective arc together with the one finite Jacobian +certificate actually consumed downstream. + +The base coordinates are represented by a projective power-series column; +after dehomogenization they may be Laurent series. The tail of `ell` is the +regular fibre covector. `gradient_identity` certifies conormality directly +using equations of the scalar-extended target ideal. The projective Euler +relation is retained as a check that `ell` is genuinely a projective +annihilating row, although the affine conormal adapter needs only its tail. +-/ +structure FiniteGradientBoundaryCertificate + (k : Type u) [Field k] + (m : ℕ) (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) where + equationCount : ℕ + q : Fin (m + 1) → PowerSeries k + ell : Fin (m + 1) → PowerSeries k + q_origin_ne : q 0 ≠ 0 + projective_annihilation : + ∑ i, laurentColumn ell i * laurentColumn q i = 0 + base_vanish : + ∀ f ∈ I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0 + equations : Fin equationCount → + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)) + coefficients : Fin equationCount → LaurentSeries k + gradient_identity : ∀ i : Fin m, + laurentColumn ell i.succ = + ∑ j, coefficients j * + differentialAt (dehomogenizedPoint (laurentColumn q)) + (equations j).1 i + residue_axis : + residueColumn (fun i : Fin m ↦ ell i.succ) = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) + +/-- The corrected finite-gradient certificate produces exactly the Laurent +conormal witness required by the canonical asymptotic step. -/ +theorem exists_conormalAxis_of_finiteGradientBoundaryCertificate + {k : Type u} [Field k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : FiniteGradientBoundaryCertificate k m hm I) : + ∃ (y : Fin m → LaurentSeries k) + (xi : Fin m → PowerSeries k), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m))) ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + let Iext := I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) + let y := dehomogenizedPoint (laurentColumn W.q) + let xi : Fin m → PowerSeries k := fun i ↦ W.ell i.succ + have hconormal : + coordinateCovector (fun i ↦ laurentColumn W.ell i.succ) ∈ + affineConormalSpace y Iext := by + exact coordinateCovector_mem_affineConormalSpace_of_finite_gradient + Iext y (fun i ↦ laurentColumn W.ell i.succ) + W.equations W.coefficients W.gradient_identity + refine ⟨y, xi, ?_, W.residue_axis⟩ + refine ⟨?_, ?_⟩ + · simpa [Iext, y] using W.base_vanish + · simpa [xi, laurentColumn, y, Iext] using hconormal + +/-! ## Pointwise handoff to the canonical producer -/ + +/-- For fixed canonical data, a finite-gradient boundary certificate has +exactly the existential conclusion demanded by +`CanonicalAsymptoticLaurentProducer`. Thus the remaining nonconstant +geometric producer may target this certificate instead of the stronger +all-tangent-space interface. -/ +theorem canonicalAsymptoticLaurentWitness_of_finiteGradientBoundaryCertificate + {k : Type u} [Field k] [CharZero k] [IsAlgClosed k] + (n N : ℕ) (d : PresentedWeyl k (n + 1)) + (W : FiniteGradientBoundaryCertificate k (n + 1) + (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N))) : + ∃ (y : Fin (n + 1) → LaurentSeries k) + (xi : Fin (n + 1) → PowerSeries k), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + ((reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin (n + 1)))) ∧ + residueColumn xi = pureMomentumFibreAxis k n := by + obtain ⟨y, xi, hmem, haxis⟩ := + exists_conormalAxis_of_finiteGradientBoundaryCertificate + (k := k) (m := n + 1) (Nat.zero_lt_succ n) + (reducedOrderBaseIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)) W + exact ⟨y, xi, hmem, haxis⟩ + + +end + +end Stafford38.Geometry.FiniteGradientBoundaryProducer diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientFromTangentInclusion.lean b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientFromTangentInclusion.lean new file mode 100644 index 0000000000..5139ea2bec --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientFromTangentInclusion.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientBoundaryProducer +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveTangentInclusion + +/-! +# Extracting a finite gradient certificate from tangent inclusion + +The formal-divisor construction already produces a projective power-series +arc and a row annihilating its explicit tangent columns. The remaining local +commutative-algebra condition is that the equation-defined Zariski tangent +space at the dehomogenized Laurent point be contained in the span of those +columns. Under exactly that condition, finite-dimensional annihilator +duality places the affine tail of the row in the span of equation +differentials. A finitely supported expansion can then be reindexed by a +finite type, producing the finite-gradient boundary certificate used by the +canonical asymptotic consumer. + +Thus no separate finite-generation theorem for the ideal is needed. The +global normalization argument has only to establish the displayed tangent +inclusion for the completed boundary chart (and separately handle any +residue-field transport). +-/ + +namespace Stafford38.Geometry.FiniteGradientFromTangentInclusion + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.FiniteGradientBoundaryProducer +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ProjectiveTangentInclusion +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +variable {k : Type u} [Field k] + +/-! ## Finite reindexing of an equation-differential expansion -/ + +/-- Membership of a coordinate covector in the equation conormal space gives +an honest `Fin r`-indexed gradient identity. This is the finite-support +content of `Submodule.span`; it does not require the whole ideal to be +finitely generated. -/ +theorem exists_fin_gradient_identity_of_mem_affineConormalSpace + {m : ℕ} + (I : Ideal (MvPolynomial (Fin m) k)) + (y xi : Fin m → k) + (hxi : coordinateCovector xi ∈ affineConormalSpace y I) : + ∃ (r : ℕ) (equations : Fin r → I) (coefficients : Fin r → k), + ∀ i, xi i = ∑ j, coefficients j * differentialAt y (equations j).1 i := by + classical + obtain ⟨c, hc⟩ := + coordinate_mem_affineConormalSpace_exists_finsupp y xi I hxi + let ι := {f : I // f ∈ c.support} + let e : ι ≃ Fin (Fintype.card ι) := Fintype.equivFin ι + let equations : Fin (Fintype.card ι) → I := fun j ↦ (e.symm j).1 + let coefficients : Fin (Fintype.card ι) → k := fun j ↦ c (e.symm j).1 + refine ⟨Fintype.card ι, equations, coefficients, fun i ↦ ?_⟩ + rw [hc i] + calc + ∑ f ∈ c.support, c f * differentialAt y f.1 i = + ∑ f : ι, c f.1 * differentialAt y f.1.1 i := by + exact Finset.sum_subtype c.support (by simp) + (fun f ↦ c f * differentialAt y f.1 i) + _ = ∑ j : Fin (Fintype.card ι), + coefficients j * differentialAt y (equations j).1 i := by + exact Fintype.sum_equiv e _ _ (fun f ↦ by + simp [coefficients, equations]) + +/-! ## Completed formal chart to finite-gradient certificate -/ + +/-- A formal projective row plus the standard tangent-inclusion condition +constructs the complete finite-gradient boundary certificate. + +This theorem identifies the exact higher-dimensional local bridge left to +the normalization argument: prove the Zariski tangent space of the +scalar-extended ambient ideal is contained in the dehomogenized span of the +formal divisor and normalized transverse columns. Once that inclusion is +available, Mathlib's finite-dimensional annihilator and finite-support span +machinery supplies the finite equations and coefficients automatically. -/ +theorem exists_finiteGradientBoundaryCertificate_of_zariski_le_formalSpan + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + {κ : Type*} [Fintype κ] + (q ell : Fin (m + 1) → PowerSeries k) + (Z : Matrix (Fin (m + 1)) κ (PowerSeries k)) + (tau : Fin (m + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m))) ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau)) + (hresidue : + residueColumn (fun i : Fin m ↦ ell i.succ) = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0)) : + Nonempty (FiniteGradientBoundaryCertificate k m hm I) := by + let Iext := I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin m)) + let y := dehomogenizedPoint (laurentColumn q) + let xi : Fin m → LaurentSeries k := fun i ↦ laurentColumn ell i.succ + have hconormal : coordinateCovector xi ∈ affineConormalSpace y Iext := by + exact coordinateCovector_mem_affineConormalSpace_of_zariski_le_span + Iext (laurentColumn q) (laurentColumn ell) + (laurentNonpositionTangentMatrix Z tau) + (laurentColumn_ne_zero_of_ne_zero q hq0) + (laurentColumn_dot_eq_zero_of_formalTangent_rowMul q ell Z tau hrow) + (laurentNonposition_rowMul_eq_zero_of_formalTangent_rowMul + q ell Z tau hrow) + htangent + obtain ⟨r, equations, coefficients, hgradient⟩ := + exists_fin_gradient_identity_of_mem_affineConormalSpace + Iext y xi hconormal + exact ⟨{ + equationCount := r + q := q + ell := ell + q_origin_ne := hq0 + projective_annihilation := + laurentColumn_dot_eq_zero_of_formalTangent_rowMul q ell Z tau hrow + base_vanish := hbase + equations := equations + coefficients := coefficients + gradient_identity := hgradient + residue_axis := hresidue + }⟩ + + +end + +end Stafford38.Geometry.FiniteGradientFromTangentInclusion diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientResidueExtension.lean b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientResidueExtension.lean new file mode 100644 index 0000000000..54a2d0bd18 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FiniteGradientResidueExtension.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientBoundaryProducer +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalResidueExtension + +/-! +# Finite-gradient certificates over a boundary residue field + +A boundary divisor can have residue field `K` strictly larger than the ground +field `k`. The completed arc and its conormal covector then naturally have +coefficients in `PowerSeries K`, while the affine ideal and the fibre symbol +remain defined over `k`. + +This file gives the finite-gradient certificate in that coefficient tower and +connects it directly to the residue-extension fibre-symbol contradiction. No +map `K → k`, algebraic-closedness of `K`, normalization, boundary divisor, or +global certificate construction is assumed. +-/ + +namespace Stafford38.Geometry.FiniteGradientResidueExtension + +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.FiniteGradientBoundaryProducer +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-- A completed projective arc and one finite gradient identity over the +natural boundary residue field `K`, for an affine ideal defined over `k`. -/ +structure FiniteGradientBoundaryCertificateOver + (m : ℕ) (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) where + equationCount : ℕ + q : Fin (m + 1) → PowerSeries K + ell : Fin (m + 1) → PowerSeries K + q_origin_ne : q 0 ≠ 0 + projective_annihilation : + ∑ i, laurentColumn ell i * laurentColumn q i = 0 + base_vanish : + ∀ f ∈ I.map (groundPolynomialMap (k := k) (K := K) (Fin m)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0 + equations : Fin equationCount → + I.map (groundPolynomialMap (k := k) (K := K) (Fin m)) + coefficients : Fin equationCount → LaurentSeries K + gradient_identity : ∀ i : Fin m, + laurentColumn ell i.succ = + ∑ j, coefficients j * + differentialAt (dehomogenizedPoint (laurentColumn q)) + (equations j).1 i + residue_axis : + residueColumn (fun i : Fin m ↦ ell i.succ) = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) + +/-- A residue-field finite-gradient certificate gives exactly the +`K((t))`-valued equation-conormal point needed by residue specialization. -/ +theorem exists_groundConormalAxis_of_finiteGradientBoundaryCertificateOver + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : FiniteGradientBoundaryCertificateOver + (k := k) (K := K) m hm I) : + ∃ (y : Fin m → LaurentSeries K) + (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + let Iext := I.map (groundPolynomialMap (k := k) (K := K) (Fin m)) + let y := dehomogenizedPoint (laurentColumn W.q) + let xi : Fin m → PowerSeries K := fun i ↦ W.ell i.succ + have hconormal : + coordinateCovector (fun i ↦ laurentColumn W.ell i.succ) ∈ + affineConormalSpace y Iext := by + exact coordinateCovector_mem_affineConormalSpace_of_finite_gradient + Iext y (fun i ↦ laurentColumn W.ell i.succ) + W.equations W.coefficients W.gradient_identity + refine ⟨y, xi, ?_, W.residue_axis⟩ + refine ⟨?_, ?_⟩ + · simpa [Iext, y, groundEquationConormalLocus] using W.base_vanish + · simpa [xi, laurentColumn, y, Iext] using hconormal + +/-- Evaluation on the coordinate axis commutes with extension from `k` to +`K`. This is the only scalar-extension fact needed for the terminal value +`P(axis)=1`. -/ +theorem eval₂_extensionAxis_eq_algebraMap_eval_axis + {m : ℕ} (hm : 0 < m) (P : MvPolynomial (Fin m) k) : + MvPolynomial.eval₂ (algebraMap k K) + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) P = + algebraMap k K + (MvPolynomial.eval + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) P) := by + have hpoint : + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then (1 : K) else 0) = + fun i ↦ algebraMap k K + (if i = ⟨0, hm⟩ then (1 : k) else 0) := by + funext i + split <;> simp_all + rw [hpoint] + exact (MvPolynomial.map_eval₂Hom + (RingHom.id k) + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then (1 : k) else 0) + (algebraMap k K) P).symm + +/-- Direct terminal contradiction from a residue-field finite-gradient +certificate. The symbol and its axis value stay over `k`; the completed arc +and all gradient coefficients may live over an arbitrary extension `K/k`. -/ +theorem false_of_finiteGradientBoundaryCertificateOver + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (P : MvPolynomial (Fin m) k) + (W : FiniteGradientBoundaryCertificateOver + (k := k) (K := K) m hm I) + (hvanishes : + ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) I, + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = 0) + (haxis : MvPolynomial.eval + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) P = 1) : False := by + obtain ⟨y, xi, hgeneric, hresidue⟩ := + exists_groundConormalAxis_of_finiteGradientBoundaryCertificateOver + (k := k) (K := K) hm I W + apply false_of_ground_fibreOnly_symbol_one_on_residue_and_vanishing + (k := k) (K := K) I P + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) + y xi hgeneric hresidue hvanishes + rw [eval₂_extensionAxis_eq_algebraMap_eval_axis (K := K) hm P, haxis] + exact map_one (algebraMap k K) + + +end + +end Stafford38.Geometry.FiniteGradientResidueExtension diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FiniteSeparableDVRChartFoundation.lean b/LeanPool/Stafford38/Stafford38/Geometry/FiniteSeparableDVRChartFoundation.lean new file mode 100644 index 0000000000..aa8c83ab83 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FiniteSeparableDVRChartFoundation.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Etale.Field +import Mathlib.RingTheory.Smooth.Basic +import Mathlib.RingTheory.Unramified.Basic + +/-! +# Finite-separable coefficient sections through nilpotent thickenings + +Let `K/E` be a separable field extension. Formal etaleness constructs a +unique `E`-algebra section of every surjective `E`-algebra map to `K` whose +kernel is nilpotent. These sections are automatically compatible with maps +between such thickenings. + +Applied to the quotients of an equicharacteristic DVR by positive powers of +its maximal ideal, this supplies the finite-level coefficient fields needed +for a completed power-series chart. The passage from this compatible family +to the inverse limit is outside this module's finite-level scope; the +completion comparison is supplied by the downstream completed-DVR chart. +-/ + +namespace Stafford38.Geometry.FiniteSeparableDVRChartFoundation + +noncomputable section + +universe u + +variable (E K R : Type u) +variable [Field E] [Field K] [CommRing R] +variable [Algebra E K] [Algebra E R] + +/-- The canonical coefficient-field lift through a nilpotent thickening. + +The construction uses only the formal smoothness of the separable field +extension `K/E`; in particular it does not assume a coefficient field in `R`. +-/ +def finiteSeparableSection + (hsep : Algebra.IsSeparable E K) + (residue : R →ₐ[E] K) + (hsurj : Function.Surjective residue) + (hnil : IsNilpotent (RingHom.ker residue.toRingHom)) : + K →ₐ[E] R := by + letI : Algebra.IsSeparable E K := hsep + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + exact Algebra.FormallySmooth.liftOfSurjective + (AlgHom.id E K) residue hsurj hnil + +/-- The canonical lift is a section of the residue homomorphism. -/ +@[simp] +theorem residue_comp_finiteSeparableSection + (hsep : Algebra.IsSeparable E K) + (residue : R →ₐ[E] K) + (hsurj : Function.Surjective residue) + (hnil : IsNilpotent (RingHom.ker residue.toRingHom)) : + residue.comp (finiteSeparableSection E K R hsep residue hsurj hnil) = + AlgHom.id E K := by + letI : Algebra.IsSeparable E K := hsep + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + exact Algebra.FormallySmooth.comp_liftOfSurjective + (AlgHom.id E K) residue hsurj hnil + +/-- Every coefficient-field lift through the same nilpotent thickening is the +canonical one. This is the formal-unramified half of separability. -/ +theorem finiteSeparableSection_unique + (hsep : Algebra.IsSeparable E K) + (residue : R →ₐ[E] K) + (hsurj : Function.Surjective residue) + (hnil : IsNilpotent (RingHom.ker residue.toRingHom)) + (lift : K →ₐ[E] R) + (hlift : residue.comp lift = AlgHom.id E K) : + lift = finiteSeparableSection E K R hsep residue hsurj hnil := by + letI : Algebra.IsSeparable E K := hsep + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + apply Algebra.FormallyUnramified.lift_unique' residue hnil + rw [hlift, residue_comp_finiteSeparableSection] + +/-- A separable residue field has a unique coefficient-field section through +every surjective nilpotent `E`-algebra thickening. -/ +theorem existsUnique_finiteSeparableSection + (hsep : Algebra.IsSeparable E K) + (residue : R →ₐ[E] K) + (hsurj : Function.Surjective residue) + (hnil : IsNilpotent (RingHom.ker residue.toRingHom)) : + ∃! lift : K →ₐ[E] R, + residue.comp lift = AlgHom.id E K := by + refine ⟨finiteSeparableSection E K R hsep residue hsurj hnil, + residue_comp_finiteSeparableSection E K R hsep residue hsurj hnil, ?_⟩ + intro lift hlift + exact finiteSeparableSection_unique E K R hsep residue hsurj hnil + lift hlift + +section Compatibility + +variable (S : Type u) [CommRing S] [Algebra E S] + +/-- The finite-level coefficient sections are compatible with every +`E`-algebra transition map commuting with residue specialization. Thus no +extra choices have to be synchronized along an Artinian quotient tower. -/ +theorem finiteSeparableSection_naturality + (hsep : Algebra.IsSeparable E K) + (residueR : R →ₐ[E] K) + (hsurjR : Function.Surjective residueR) + (hnilR : IsNilpotent (RingHom.ker residueR.toRingHom)) + (residueS : S →ₐ[E] K) + (hsurjS : Function.Surjective residueS) + (hnilS : IsNilpotent (RingHom.ker residueS.toRingHom)) + (transition : S →ₐ[E] R) + (htransition : residueR.comp transition = residueS) : + transition.comp + (finiteSeparableSection E K S hsep residueS hsurjS hnilS) = + finiteSeparableSection E K R hsep residueR hsurjR hnilR := by + apply finiteSeparableSection_unique E K R hsep residueR hsurjR hnilR + rw [← AlgHom.comp_assoc, htransition, + residue_comp_finiteSeparableSection] + +end Compatibility + + +end + +end Stafford38.Geometry.FiniteSeparableDVRChartFoundation diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FixedWitnessTangentSqueeze.lean b/LeanPool/Stafford38/Stafford38/Geometry/FixedWitnessTangentSqueeze.lean new file mode 100644 index 0000000000..0a6e27f31f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FixedWitnessTangentSqueeze.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan + +/-! +# A finite family determines the tangent space at full rank + +If a finite linearly independent family consists of Zariski tangent vectors +and the tangent space has dimension at most the size of the family, then the +tangent space is exactly their span. This is only the finite-dimensional +linear-algebra consumer; it does not construct tangent vectors or establish a +smoothness or dimension bound. +-/ + +namespace Stafford38.Geometry.FixedWitnessTangentSqueeze + +open Stafford38.Geometry.AffineConormalSpan + +noncomputable section + +variable {K : Type*} [Field K] {n : ℕ} + +/-- A fixed independent tangent family spans the whole Zariski tangent space +once the tangent dimension is bounded by the cardinality of that family. -/ +theorem fixedWitnessTangentSqueeze + {κ : Type*} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) K)) + (y : Fin n → K) + (b : κ → AffineTangentVector K n) + (hb : ∀ j, b j ∈ zariskiTangentSpace y I) + (hindependent : LinearIndependent K b) + (hfinrank : Module.finrank K (zariskiTangentSpace y I) ≤ Fintype.card κ) : + zariskiTangentSpace y I = Submodule.span K (Set.range b) := by + classical + have hspan_le : + Submodule.span K (Set.range b) ≤ zariskiTangentSpace y I := by + refine Submodule.span_le.mpr ?_ + rintro _ ⟨j, rfl⟩ + exact hb j + have hrank : + Module.finrank K (zariskiTangentSpace y I) ≤ + Module.finrank K (Submodule.span K (Set.range b)) := by + rw [finrank_span_eq_card hindependent] + exact hfinrank + exact (Submodule.eq_of_le_of_finrank_le hspan_le hrank).symm + +/-- The reverse inclusion needed by the conormal consumer. -/ +theorem fixedWitnessTangent_le_span + {κ : Type*} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) K)) + (y : Fin n → K) + (b : κ → AffineTangentVector K n) + (hb : ∀ j, b j ∈ zariskiTangentSpace y I) + (hindependent : LinearIndependent K b) + (hfinrank : Module.finrank K (zariskiTangentSpace y I) ≤ Fintype.card κ) : + zariskiTangentSpace y I ≤ Submodule.span K (Set.range b) := by + rw [fixedWitnessTangentSqueeze I y b hb hindependent hfinrank] + + +end + +end Stafford38.Geometry.FixedWitnessTangentSqueeze diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorAxisLift.lean b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorAxisLift.lean new file mode 100644 index 0000000000..92625dd712 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorAxisLift.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorTangent +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesTangentLimit + +/-! +# The axis lift for a formal divisor tangent + +This file completes the local power-series part of the formal-divisor +construction. If the distinguished axis coordinate and every divisor-tangent +entry in that row vanish to order at least `b`, while the common factor removed +from the corrected transverse derivative has order at most `a - 1 < b - 1`, +then the normalized transverse tangent has zero axis residue. Consequently +the pure axis covector annihilates every reduced tangent column. + +The residue-rank theorem from `FormalDivisorTangent` supplies a power-series +left inverse. Retraction correction then produces an exact annihilator whose +residue is the pure axis covector. No normalization, projective divisor, +formal-chart construction, or global conormal-closure statement is made here. +-/ + +namespace Stafford38.GeometryFormalDivisorAxisLift + +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryPowerSeriesTangentLimit +open Stafford38.GeometryRetractionSpecialization +open Stafford38.GeometryResidueMinorSelection +open Stafford38.GeometrySplitTangentMatrix + +noncomputable section + +universe u v w + +variable {k : Type u} [Field k] + +/-! ## The strict axis-order calculation -/ + +/-- The factor removed from the corrected transverse derivative has strictly +smaller order than the axis row. Therefore the normalized transverse tangent +still vanishes at the closed point in the axis coordinate. -/ +theorem constantCoeff_normalizedTransverse_axis_eq_zero + {ι : Type v} {κ : Type w} [Fintype κ] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (lambda : κ → PowerSeries k) + (tau : ι → PowerSeries k) + (axis : ι) (a b c : ℕ) (u₁ : PowerSeries k) + (ha : 0 < a) + (hab : a < b) + (hc : c ≤ a - 1) + (hqaxis : q axis = (PowerSeries.X : PowerSeries k) ^ b * u₁) + (hZaxis : ∀ j, ∃ w : PowerSeries k, + Z axis j = (PowerSeries.X : PowerSeries k) ^ b * w) + (hfactor : + PowerSeries.derivative k (q axis) - Z.mulVec lambda axis = + (PowerSeries.X : PowerSeries k) ^ c * tau axis) : + PowerSeries.constantCoeff (tau axis) = 0 := by + have hcb : c < b := by omega + have hcsuccb : c + 1 < b := by omega + have hderivative : + PowerSeries.coeff c (PowerSeries.derivative k (q axis)) = 0 := by + rw [PowerSeries.coeff_derivative, hqaxis] + rw [PowerSeries.coeff_X_pow_mul'] + simp [Nat.not_le_of_gt hcsuccb] + have hcombination : + PowerSeries.coeff c (Z.mulVec lambda axis) = 0 := by + change PowerSeries.coeff c (∑ j, Z axis j * lambda j) = 0 + rw [map_sum] + apply Finset.sum_eq_zero + intro j hj + obtain ⟨w, hw⟩ := hZaxis j + rw [hw, mul_assoc] + rw [PowerSeries.coeff_X_pow_mul'] + simp [Nat.not_le_of_gt hcb] + have hcorrected : + PowerSeries.coeff c + (PowerSeries.derivative k (q axis) - Z.mulVec lambda axis) = 0 := by + rw [map_sub, hderivative, hcombination, sub_zero] + have hnormalized : + PowerSeries.coeff c + ((PowerSeries.X : PowerSeries k) ^ c * tau axis) = + PowerSeries.constantCoeff (tau axis) := by + simpa [PowerSeries.coeff_zero_eq_constantCoeff_apply, Nat.add_comm] using + (PowerSeries.coeff_X_pow_mul (tau axis) c 0) + rw [← hnormalized, ← hfactor] + exact hcorrected + +/-! ## The axis covector on the assembled tangent matrix -/ + +/-- Vanishing of the position, divisor, and normalized transverse entries in +the axis row gives residue-zero for every assembled tangent column. -/ +theorem constantCoeff_formalTangentMatrix_axis_eq_zero + {ι : Type v} {κ : Type w} + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) + (axis : ι) (b : ℕ) (u₁ : PowerSeries k) + (hb : 0 < b) + (hqaxis : q axis = (PowerSeries.X : PowerSeries k) ^ b * u₁) + (hZaxis : ∀ j, ∃ w : PowerSeries k, + Z axis j = (PowerSeries.X : PowerSeries k) ^ b * w) + (htauaxis : PowerSeries.constantCoeff (tau axis) = 0) : + ∀ column : FormalTangentColumn κ, + PowerSeries.constantCoeff + (formalTangentMatrix q Z tau axis column) = 0 := by + intro column + rcases column with (_ | (j | _)) + · rw [formalTangentMatrix, hqaxis] + obtain ⟨m, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt hb) + simp [pow_succ] + · rw [formalTangentMatrix] + obtain ⟨w, hw⟩ := hZaxis j + rw [hw] + obtain ⟨m, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt hb) + simp [pow_succ] + · simpa [formalTangentMatrix] using htauaxis + +/-- The pure axis covector annihilates the residue of the assembled tangent +matrix. -/ +theorem axisRow_residue_formalTangentMatrix_eq_zero + {ι : Type v} {κ : Type w} [Fintype ι] [DecidableEq ι] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) + (axis : ι) + (haxis : ∀ column : FormalTangentColumn κ, + PowerSeries.constantCoeff + (formalTangentMatrix q Z tau axis column) = 0) : + rowMul (axisRow (k := k) axis) + (fun i column => PowerSeries.constantCoeff + (formalTangentMatrix q Z tau i column)) = 0 := by + funext column + simp [rowMul, axisRow, haxis column] + +/-! ## Complete local axis lift -/ + +/-- The complete local formal-divisor axis lift. + +The correction and primitive normalization are constructed from the formal +chart data. The strict axis-order hypotheses force the pure axis covector to +annihilate the reduced tangent matrix. A left inverse derived from the same +matrix then gives an exact power-series annihilator specializing to that +covector. +-/ +theorem exists_formalDivisorAxisLift + [CharZero k] + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (rows : κ ↪ ι) (chart zero axis : ι) + (a b : ℕ) (u₀ u₁ : PowerSeries k) + (hqchart : q chart = 1) + (hZchart : ∀ j, Z chart j = 0) + (ha : 0 < a) + (hab : a < b) + (hqzero : q zero = (PowerSeries.X : PowerSeries k) ^ a * u₀) + (hu₀ : PowerSeries.constantCoeff u₀ ≠ 0) + (hZzero : ∀ j, ∃ w : PowerSeries k, + Z zero j = (PowerSeries.X : PowerSeries k) ^ a * w) + (hqaxis : q axis = (PowerSeries.X : PowerSeries k) ^ b * u₁) + (hZaxis : ∀ j, ∃ w : PowerSeries k, + Z axis j = (PowerSeries.X : PowerSeries k) ^ b * w) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) : + ∃ (lambda : κ → PowerSeries k) (c : ℕ) + (tau : ι → PowerSeries k) + (C : Matrix (FormalTangentColumn κ) ι (PowerSeries k)) + (ell : ι → PowerSeries k), + lambda = correctionCoefficients Z rows + (fun i => PowerSeries.derivative k (q i)) ∧ + (∀ j, + PowerSeries.derivative k (q (rows j)) = + Z.mulVec lambda (rows j)) ∧ + tau chart = 0 ∧ + (∀ j, tau (rows j) = 0) ∧ + c ≤ a - 1 ∧ + (∀ i, + PowerSeries.derivative k (q i) - Z.mulVec lambda i = + (PowerSeries.X : PowerSeries k) ^ c * tau i) ∧ + (∃ i, PowerSeries.constantCoeff (tau i) ≠ 0) ∧ + PowerSeries.constantCoeff (tau axis) = 0 ∧ + (∀ column : FormalTangentColumn κ, + PowerSeries.constantCoeff + (formalTangentMatrix q Z tau axis column) = 0) ∧ + C * formalTangentMatrix q Z tau = 1 ∧ + rowMul ell (formalTangentMatrix q Z tau) = 0 ∧ + residueColumn ell = axisRow (k := k) axis := by + obtain ⟨lambda, c, tau, hlambda, hselected, htauchart, + htauselected, hc, hfactor, hprimitive, hinjective⟩ := + exists_formalDivisorTangent_residue_injective + q Z rows chart zero a u₀ hqchart hZchart ha hqzero hu₀ + hZzero hminor + have htauaxis : PowerSeries.constantCoeff (tau axis) = 0 := + constantCoeff_normalizedTransverse_axis_eq_zero + q Z lambda tau axis a b c u₁ ha hab hc hqaxis hZaxis (hfactor axis) + have hb : 0 < b := lt_trans ha hab + have haxiscolumns : ∀ column : FormalTangentColumn κ, + PowerSeries.constantCoeff + (formalTangentMatrix q Z tau axis column) = 0 := + constantCoeff_formalTangentMatrix_axis_eq_zero + q Z tau axis b u₁ hb hqaxis hZaxis htauaxis + obtain ⟨C, hCB⟩ := + powerSeries_exists_leftInverse_of_residue_mulVec_injective + (formalTangentMatrix q Z tau) hinjective + let a₀ : ι → k := axisRow (k := k) axis + let ell : ι → PowerSeries k := + annihilatorLift (constantColumn a₀) + (formalTangentMatrix q Z tau) C + have hresidueInput : residueColumn (constantColumn a₀) = a₀ := + residueColumn_constantColumn a₀ + have haxisRow : + rowMul a₀ + (fun i column => PowerSeries.constantCoeff + (formalTangentMatrix q Z tau i column)) = 0 := + axisRow_residue_formalTangentMatrix_eq_zero + q Z tau axis haxiscolumns + have hell : + rowMul ell (formalTangentMatrix q Z tau) = 0 ∧ + residueColumn ell = a₀ := by + simpa [ell] using + (powerSeries_annihilatorLift_spec + (constantColumn a₀) a₀ (formalTangentMatrix q Z tau) C + hCB hresidueInput haxisRow) + exact ⟨lambda, c, tau, C, ell, hlambda, hselected, htauchart, + htauselected, hc, hfactor, hprimitive, htauaxis, haxiscolumns, + hCB, hell.1, by simpa [a₀] using hell.2⟩ + + +end + +end Stafford38.GeometryFormalDivisorAxisLift diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorLaurentConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorLaurentConormal.lean new file mode 100644 index 0000000000..bc07d76fd8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorLaurentConormal.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorAxisLift +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDehomogenization +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection + +/-! +# From a formal divisor tangent to a Laurent conormal point + +This file is the local algebraic bridge between the formal-divisor tangent +construction and Laurent conormal specialization. Projective coordinates, +an annihilating row, and the divisor and normalized-transverse tangent columns +are embedded from power series into Laurent series. The position column of +the formal tangent matrix supplies the projective Euler relation; its other +columns supply the projective tangent annihilation relation. The existing +dehomogenization theorem then gives an equation-conormal point once the base +equations and the exact affine tangent-space equality are supplied. + +No normalization or divisor chart is constructed here. In particular this +file makes no global closure, coisotropy, or Gabber claim. +-/ + +namespace Stafford38.Geometry.FormalDivisorLaurentConormal + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- Coefficientwise embedding of a power-series projective column into +Laurent series. -/ +def laurentColumn (v : Fin (n + 1) → PowerSeries k) : + Fin (n + 1) → LaurentSeries k := + fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (v i) + +/-- The divisor and normalized-transverse columns of the formal tangent +matrix, embedded in Laurent series. The position column is deliberately +omitted: it is used separately as the projective-point Euler relation. -/ +def laurentNonpositionTangentMatrix { κ : Type* } + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) : + Matrix (Fin (n + 1)) (κ ⊕ Unit) (LaurentSeries k) + | i, Sum.inl j => + algebraMap (PowerSeries k) (LaurentSeries k) (Z i j) + | i, Sum.inr _ => + algebraMap (PowerSeries k) (LaurentSeries k) (tau i) + +/-- The position component of an exact formal tangent annihilation becomes +the projective point-annihilation relation over Laurent series. -/ +theorem laurentColumn_dot_eq_zero_of_formalTangent_rowMul + { κ : Type* } [Fintype κ] + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) : + ∑ i, laurentColumn ell i * laurentColumn q i = 0 := by + have hposition := congrFun hrow (Sum.inl ()) + simp only [Pi.zero_apply, rowMul, formalTangentMatrix] at hposition + simpa [laurentColumn, map_sum] using + congrArg (algebraMap (PowerSeries k) (LaurentSeries k)) hposition + +/-- The non-position components of an exact formal tangent annihilation +become annihilation of all embedded divisor and normalized-transverse +columns. -/ +theorem laurentNonposition_rowMul_eq_zero_of_formalTangent_rowMul + { κ : Type* } [Fintype κ] + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) : + rowMul (laurentColumn ell) (laurentNonpositionTangentMatrix Z tau) = 0 := by + funext column + rcases column with j | _ + · have hj := congrFun hrow (Sum.inr (Sum.inl j)) + simp only [Pi.zero_apply, rowMul, formalTangentMatrix] at hj + simpa [rowMul, laurentColumn, laurentNonpositionTangentMatrix, map_sum] using + congrArg (algebraMap (PowerSeries k) (LaurentSeries k)) hj + · have htau := congrFun hrow (Sum.inr (Sum.inr ())) + simp only [Pi.zero_apply, rowMul, formalTangentMatrix] at htau + simpa [rowMul, laurentColumn, laurentNonpositionTangentMatrix, map_sum] using + congrArg (algebraMap (PowerSeries k) (LaurentSeries k)) htau + +/-- The power-series embedding in Laurent series is nonzero on every nonzero +power series. -/ +theorem laurentColumn_ne_zero_of_ne_zero + (q : Fin (n + 1) → PowerSeries k) (hq0 : q 0 ≠ 0) : + laurentColumn q 0 ≠ 0 := by + intro hzero + apply hq0 + apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) + simpa [laurentColumn] using hzero + +/-- The complete conditional local bridge. Exact formal row annihilation +supplies both projective relations. Given the base equations and the exact +dehomogenized tangent-space equality, the resulting Laurent phase point lies +in the equation-defined conormal locus. -/ +theorem laurentPhasePoint_mem_equationConormalLocus + { κ : Type* } [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) (LaurentSeries k))) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ I, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) = + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) I) : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ laurentColumn ell i.succ) ∈ + equationConormalLocus I := by + exact phasePoint_mem_equationConormalLocus_of_projective_row + I (laurentColumn q) (laurentColumn ell) + (laurentNonpositionTangentMatrix Z tau) + (laurentColumn_ne_zero_of_ne_zero q hq0) + (laurentColumn_dot_eq_zero_of_formalTangent_rowMul q ell Z tau hrow) + (laurentNonposition_rowMul_eq_zero_of_formalTangent_rowMul + q ell Z tau hrow) + hbase htangent + +/-- The residue of the affine covector is exactly the tail of the residue of +the formal projective annihilating row. This is the fibre-residue equality +consumed by `LaurentConormalDirection`. -/ +theorem residueColumn_tail + (ell : Fin (n + 1) → PowerSeries k) : + residueColumn (fun i : Fin n ↦ ell i.succ) = + fun i ↦ residueColumn ell i.succ := by + rfl + +/-- Package the conormal membership together with the exact residue relation +for its regular fibre coordinates. -/ +theorem laurentPhasePoint_mem_equationConormalLocus_and_residue + { κ : Type* } [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) (LaurentSeries k))) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ I, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) = + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) I) : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (ell i.succ)) ∈ + equationConormalLocus I ∧ + residueColumn (fun i : Fin n ↦ ell i.succ) = + fun i ↦ residueColumn ell i.succ := by + exact ⟨laurentPhasePoint_mem_equationConormalLocus + I q ell Z tau hq0 hrow hbase htangent, residueColumn_tail ell⟩ + +/-- Direct handoff to `LaurentConormalDirection` for a scalar-extended base +ideal. The possibly singular dehomogenized position is retained over Laurent +series, while the regular fibre is the power-series tail of `ell`. -/ +theorem residue_tail_mem_laurentEquationConormalDirectionClosure + { κ : Type* } [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) k)) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) = + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) : + residueColumn (fun i : Fin n ↦ ell i.succ) ∈ + laurentEquationConormalDirectionClosure I := by + apply residue_mem_laurentEquationConormalDirectionClosure + I (dehomogenizedPoint (laurentColumn q)) (fun i : Fin n ↦ ell i.succ) + exact laurentPhasePoint_mem_equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + q ell Z tau hq0 hrow hbase htangent + + +end + +end Stafford38.Geometry.FormalDivisorLaurentConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorTangent.lean b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorTangent.lean new file mode 100644 index 0000000000..6e5cce573a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/FormalDivisorTangent.lean @@ -0,0 +1,400 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ResidueMinorSelection +import Mathlib.RingTheory.PowerSeries.Derivative +import Mathlib.Data.Nat.Find + +/-! +# Correcting and normalizing a formal divisor tangent + +This file supplies the first constructive part of the formal-divisor argument. +An invertible selected minor of the divisor-tangent matrix gives regular +correction coefficients which kill the selected rows of a transverse +derivative. If one distinguished coordinate has positive order `a`, while +the divisor-tangent columns have order at least `a` there, characteristic zero +leaves a nonzero coefficient in degree `a - 1` after correction. Taking the +least nonzero coefficient of the corrected vector then produces a common +power of `X` and a primitive normalized vector. + +Every output is constructed from the displayed equations. No residue-rank, +saturation, splitting, or left-inverse hypothesis is assumed. +-/ + +namespace Stafford38.GeometryFormalDivisorTangent + +open Stafford38.GeometrySplitTangentMatrix +open Stafford38.GeometryResidueMinorSelection + +noncomputable section + +universe u v w + +variable {k : Type u} [Field k] + +/-! ## The first nonzero derivative coefficient -/ + +/-- Differentiating `X^(a+1) u` leaves the expected nonzero leading +coefficient in degree `a`. -/ +theorem coeff_derivative_X_pow_succ_mul + [CharZero k] (u : PowerSeries k) (a : ℕ) : + PowerSeries.coeff a + (PowerSeries.derivative k + ((PowerSeries.X : PowerSeries k) ^ (a + 1) * u)) = + PowerSeries.constantCoeff u * ((a + 1 : ℕ) : k) := by + rw [PowerSeries.coeff_derivative] + congr 1 + simpa [PowerSeries.coeff_zero_eq_constantCoeff_apply, Nat.add_comm] using + (PowerSeries.coeff_X_pow_mul u (a + 1) 0) + simp + +/-- In characteristic zero the leading derivative coefficient above cannot +vanish when the leading coefficient of `u` is nonzero. -/ +theorem coeff_derivative_X_pow_succ_mul_ne_zero + [CharZero k] (u : PowerSeries k) (a : ℕ) + (hu : PowerSeries.constantCoeff u ≠ 0) : + PowerSeries.coeff a + (PowerSeries.derivative k + ((PowerSeries.X : PowerSeries k) ^ (a + 1) * u)) ≠ 0 := by + rw [coeff_derivative_X_pow_succ_mul] + exact mul_ne_zero hu (Nat.cast_ne_zero.mpr (Nat.succ_ne_zero a)) + +/-- The same leading-coefficient statement in the geometric indexing: +`q = X^a u` with `a > 0` has a nonzero derivative coefficient in degree +`a - 1`. -/ +theorem coeff_derivative_X_pow_mul_ne_zero + [CharZero k] (q u : PowerSeries k) (a : ℕ) + (ha : 0 < a) + (hq : q = (PowerSeries.X : PowerSeries k) ^ a * u) + (hu : PowerSeries.constantCoeff u ≠ 0) : + PowerSeries.coeff (a - 1) (PowerSeries.derivative k q) ≠ 0 := by + obtain ⟨b, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt ha) + simpa [hq] using coeff_derivative_X_pow_succ_mul_ne_zero u b hu + +/-! ## Selected-minor correction -/ + +/-- Coefficients obtained by solving the selected square subsystem. -/ +def correctionCoefficients + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (Z : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) + (v : ι → PowerSeries k) : κ → PowerSeries k := + ((selectedMinor Z rows)⁻¹).mulVec fun j => v (rows j) + +/-- Subtract the divisor-tangent combination determined by the selected +minor. -/ +def correctedVector + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (Z : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) + (v : ι → PowerSeries k) : ι → PowerSeries k := + fun i => v i - Z.mulVec (correctionCoefficients Z rows v) i + +/-- A selected minor with nonzero residue determinant eliminates every +selected row exactly over the power-series ring. -/ +theorem correctedVector_selectedRow_eq_zero + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (Z : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) + (v : ι → PowerSeries k) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) : + ∀ j, correctedVector Z rows v (rows j) = 0 := by + have hunit : IsUnit (selectedMinor Z rows).det := by + rw [PowerSeries.isUnit_iff_constantCoeff] + exact isUnit_iff_ne_zero.mpr hminor + have hinv : + selectedMinor Z rows * (selectedMinor Z rows)⁻¹ = 1 := + Matrix.mul_nonsing_inv _ hunit + intro j + have hsolve : + (selectedMinor Z rows).mulVec (correctionCoefficients Z rows v) = + fun a => v (rows a) := by + rw [correctionCoefficients, Matrix.mulVec_mulVec, hinv] + exact Matrix.one_mulVec _ + change v (rows j) - + (selectedMinor Z rows).mulVec (correctionCoefficients Z rows v) j = 0 + rw [hsolve] + exact sub_self _ + +/-! ## Primitive common-power normalization -/ + +/-- A vector with a displayed nonzero coefficient has a least common +`X`-order. Dividing every component by that common power produces a +primitive vector: at least one component has nonzero constant coefficient. + +No finiteness assumption on the coordinate type is needed; well-ordering of +the coefficient degree supplies the minimum. -/ +theorem exists_primitive_commonPower_of_coeff_ne_zero + {ι : Type v} (T : ι → PowerSeries k) (i₀ : ι) (bound : ℕ) + (hcoeff : PowerSeries.coeff bound (T i₀) ≠ 0) : + ∃ c : ℕ, c ≤ bound ∧ + ∃ B : ι → PowerSeries k, + (∀ i, T i = (PowerSeries.X : PowerSeries k) ^ c * B i) ∧ + ∃ i, PowerSeries.constantCoeff (B i) ≠ 0 := by + classical + let p : ℕ → Prop := fun d => ∃ i, PowerSeries.coeff d (T i) ≠ 0 + have hp : ∃ d, p d := ⟨bound, i₀, hcoeff⟩ + let c : ℕ := Nat.find hp + have hc_le : c ≤ bound := Nat.find_min' hp ⟨i₀, hcoeff⟩ + have hbelow : ∀ i m, m < c → PowerSeries.coeff m (T i) = 0 := by + intro i m hm + by_contra hne + apply Nat.find_min hp (m := m) + · simpa [c] using hm + · exact ⟨i, hne⟩ + have hdvd : ∀ i, (PowerSeries.X : PowerSeries k) ^ c ∣ T i := by + intro i + exact PowerSeries.X_pow_dvd_iff.mpr fun m hm => hbelow i m hm + choose B hB using hdvd + refine ⟨c, hc_le, B, ?_, ?_⟩ + · intro i + exact hB i + · obtain ⟨i, hi⟩ := Nat.find_spec hp + refine ⟨i, ?_⟩ + have hcoefficient : + PowerSeries.coeff c (T i) = + PowerSeries.constantCoeff (B i) := by + rw [hB i] + simpa [PowerSeries.coeff_zero_eq_constantCoeff_apply, Nat.add_comm] using + (PowerSeries.coeff_X_pow_mul (B i) c 0) + rwa [hcoefficient] at hi + +/-! ## The explicit normalized tangent matrix -/ + +/-- Columns of the formal tangent matrix: position, divisor tangents, and the +normalized transverse tangent. -/ +abbrev FormalTangentColumn (κ : Type*) := Unit ⊕ (κ ⊕ Unit) + +/-- Assemble the position, divisor-tangent, and normalized transverse columns +without making any rank assertion. -/ +def formalTangentMatrix + {ι : Type v} {κ : Type w} + (q : ι → PowerSeries k) (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) : + Matrix ι (FormalTangentColumn κ) (PowerSeries k) + | i, Sum.inl _ => q i + | i, Sum.inr (Sum.inl j) => Z i j + | i, Sum.inr (Sum.inr _) => tau i + +/-- The chart row, selected divisor minor, and one primitive normalized entry +give an explicit pivot proof that the normalized tangent matrix has full +column rank after reduction modulo `X`. -/ +theorem residue_formalTangentMatrix_mulVec_injective + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (q : ι → PowerSeries k) (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) (rows : κ ↪ ι) (chart : ι) + (hqchart : q chart = 1) + (hZchart : ∀ j, Z chart j = 0) + (htauchart : tau chart = 0) + (htauselected : ∀ j, tau (rows j) = 0) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) + (hprimitive : ∃ i, PowerSeries.constantCoeff (tau i) ≠ 0) : + Function.Injective + (residueMatrix (formalTangentMatrix q Z tau)).mulVec := by + classical + intro c₁ c₂ hc + apply sub_eq_zero.mp + let c : FormalTangentColumn κ → k := c₁ - c₂ + have hc₀ : + (residueMatrix (formalTangentMatrix q Z tau)).mulVec c = 0 := by + change (residueMatrix (formalTangentMatrix q Z tau)).mulVec (c₁ - c₂) = 0 + rw [Matrix.mulVec_sub, hc, sub_self] + have hposition : c (Sum.inl ()) = 0 := by + have hchart := congrFun hc₀ chart + simpa [Matrix.mulVec, dotProduct, residueMatrix, formalTangentMatrix, + hqchart, hZchart, htauchart] using hchart + let zc : κ → k := fun j => c (Sum.inr (Sum.inl j)) + have hdivisor : (selectedMinor (residueMatrix Z) rows).mulVec zc = 0 := by + funext j + have hrow := congrFun hc₀ (rows j) + simpa [Matrix.mulVec, dotProduct, selectedMinor, residueMatrix, + formalTangentMatrix, zc, hposition, htauselected] using hrow + have hminor_residue : (selectedMinor (residueMatrix Z) rows).det ≠ 0 := by + rw [← constantCoeff_selectedMinor_det] + exact hminor + have hdivisor_zero : zc = 0 := by + have hinjective : + Function.Injective (selectedMinor (residueMatrix Z) rows).mulVec := by + apply Matrix.mulVec_injective_iff_isUnit.mpr + rw [Matrix.isUnit_iff_isUnit_det] + exact isUnit_iff_ne_zero.mpr hminor_residue + apply hinjective + simpa using hdivisor + obtain ⟨pivot, hpivot⟩ := hprimitive + have htransverse : c (Sum.inr (Sum.inr ())) = 0 := by + have hp := congrFun hc₀ pivot + have hz : ∀ j, c (Sum.inr (Sum.inl j)) = 0 := by + intro j + exact congrFun hdivisor_zero j + simpa [Matrix.mulVec, dotProduct, residueMatrix, formalTangentMatrix, + hposition, hz, hpivot] using hp + have hc_zero : c = 0 := by + funext column + rcases column with (_ | (j | _)) + · exact hposition + · exact congrFun hdivisor_zero j + · exact htransverse + simpa [c] using hc_zero + +/-- The same explicit pivots construct a power-series left inverse for the +assembled tangent matrix; no splitting hypothesis is used. -/ +theorem exists_formalTangentMatrix_leftInverse + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (q : ι → PowerSeries k) (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) (rows : κ ↪ ι) (chart : ι) + (hqchart : q chart = 1) + (hZchart : ∀ j, Z chart j = 0) + (htauchart : tau chart = 0) + (htauselected : ∀ j, tau (rows j) = 0) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) + (hprimitive : ∃ i, PowerSeries.constantCoeff (tau i) ≠ 0) : + ∃ C : Matrix (FormalTangentColumn κ) ι (PowerSeries k), + C * formalTangentMatrix q Z tau = 1 := by + apply powerSeries_exists_leftInverse_of_residue_mulVec_injective + exact residue_formalTangentMatrix_mulVec_injective + q Z tau rows chart hqchart hZchart htauchart htauselected + hminor hprimitive + +/-! ## Combined formal-divisor producer -/ + +/-- The explicit correction-and-normalization block used in the formal +divisor tangent construction. + +The selected minor constructs `lambda` and kills its selected rows. The +distinguished coordinate equation and divisibility of the corresponding row +of `Z` guarantee that the correction cannot cancel the first nonzero +derivative coefficient. Hence the corrected transverse derivative admits a +primitive common-power normalization of order at most `a - 1`. +-/ +theorem exists_corrected_primitive_formalDivisorTangent + [CharZero k] + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (rows : κ ↪ ι) (zero : ι) + (a : ℕ) (u₀ : PowerSeries k) + (ha : 0 < a) + (hqzero : q zero = (PowerSeries.X : PowerSeries k) ^ a * u₀) + (hu₀ : PowerSeries.constantCoeff u₀ ≠ 0) + (hZzero : ∀ j, ∃ w : PowerSeries k, + Z zero j = (PowerSeries.X : PowerSeries k) ^ a * w) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) : + ∃ (lambda : κ → PowerSeries k) (c : ℕ) + (tau : ι → PowerSeries k), + lambda = correctionCoefficients Z rows + (fun i => PowerSeries.derivative k (q i)) ∧ + (∀ j, + PowerSeries.derivative k (q (rows j)) = + Z.mulVec lambda (rows j)) ∧ + (∀ j, tau (rows j) = 0) ∧ + c ≤ a - 1 ∧ + (∀ i, + PowerSeries.derivative k (q i) - Z.mulVec lambda i = + (PowerSeries.X : PowerSeries k) ^ c * tau i) ∧ + ∃ i, PowerSeries.constantCoeff (tau i) ≠ 0 := by + let v : ι → PowerSeries k := fun i => PowerSeries.derivative k (q i) + let lambda : κ → PowerSeries k := correctionCoefficients Z rows v + let T : ι → PowerSeries k := correctedVector Z rows v + have hselected : ∀ j, T (rows j) = 0 := by + exact correctedVector_selectedRow_eq_zero Z rows v hminor + have hderiv : PowerSeries.coeff (a - 1) (v zero) ≠ 0 := by + exact coeff_derivative_X_pow_mul_ne_zero (q zero) u₀ a ha hqzero hu₀ + have hcombination : + PowerSeries.coeff (a - 1) (Z.mulVec lambda zero) = 0 := by + change PowerSeries.coeff (a - 1) + (∑ j, Z zero j * lambda j) = 0 + rw [map_sum] + apply Finset.sum_eq_zero + intro j hj + obtain ⟨w, hw⟩ := hZzero j + rw [hw, mul_assoc] + rw [PowerSeries.coeff_X_pow_mul'] + simp [Nat.not_le_of_gt (Nat.sub_lt ha Nat.zero_lt_one)] + have hTcoeff : PowerSeries.coeff (a - 1) (T zero) ≠ 0 := by + change PowerSeries.coeff (a - 1) + (v zero - Z.mulVec lambda zero) ≠ 0 + rw [map_sub, hcombination, sub_zero] + exact hderiv + obtain ⟨c, hc, tau, hfactor, hprimitive⟩ := + exists_primitive_commonPower_of_coeff_ne_zero T zero (a - 1) hTcoeff + refine ⟨lambda, c, tau, rfl, ?_, ?_, hc, ?_, hprimitive⟩ + · intro j + have hz := hselected j + change v (rows j) - Z.mulVec lambda (rows j) = 0 at hz + exact sub_eq_zero.mp hz + · intro j + have hz : (PowerSeries.X : PowerSeries k) ^ c * tau (rows j) = 0 := by + rw [← hfactor (rows j), hselected j] + exact (mul_eq_zero.mp hz).resolve_left + (pow_ne_zero c PowerSeries.X_ne_zero) + · intro i + exact hfactor i + +/-- With an explicit affine chart row, the corrected primitive tangent above +assembles into a matrix whose residue columns are injective. This is the +complete local formal-divisor producer: residue injectivity is a conclusion, +not an input. -/ +theorem exists_formalDivisorTangent_residue_injective + [CharZero k] + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (rows : κ ↪ ι) (chart zero : ι) + (a : ℕ) (u₀ : PowerSeries k) + (hqchart : q chart = 1) + (hZchart : ∀ j, Z chart j = 0) + (ha : 0 < a) + (hqzero : q zero = (PowerSeries.X : PowerSeries k) ^ a * u₀) + (hu₀ : PowerSeries.constantCoeff u₀ ≠ 0) + (hZzero : ∀ j, ∃ w : PowerSeries k, + Z zero j = (PowerSeries.X : PowerSeries k) ^ a * w) + (hminor : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0) : + ∃ (lambda : κ → PowerSeries k) (c : ℕ) + (tau : ι → PowerSeries k), + lambda = correctionCoefficients Z rows + (fun i => PowerSeries.derivative k (q i)) ∧ + (∀ j, + PowerSeries.derivative k (q (rows j)) = + Z.mulVec lambda (rows j)) ∧ + tau chart = 0 ∧ + (∀ j, tau (rows j) = 0) ∧ + c ≤ a - 1 ∧ + (∀ i, + PowerSeries.derivative k (q i) - Z.mulVec lambda i = + (PowerSeries.X : PowerSeries k) ^ c * tau i) ∧ + (∃ i, PowerSeries.constantCoeff (tau i) ≠ 0) ∧ + Function.Injective + (residueMatrix (formalTangentMatrix q Z tau)).mulVec := by + obtain ⟨lambda, c, tau, hlambda, hselected, htauselected, + hc, hfactor, hprimitive⟩ := + exists_corrected_primitive_formalDivisorTangent + q Z rows zero a u₀ ha hqzero hu₀ hZzero hminor + have hderivative_chart : PowerSeries.derivative k (q chart) = 0 := by + simp [hqchart] + have hcombination_chart : Z.mulVec lambda chart = 0 := by + simp [Matrix.mulVec, dotProduct, hZchart] + have htauchart : tau chart = 0 := by + have hz := hfactor chart + rw [hderivative_chart, hcombination_chart, sub_zero] at hz + have hproduct : (PowerSeries.X : PowerSeries k) ^ c * tau chart = 0 := + hz.symm + exact (mul_eq_zero.mp hproduct).resolve_left + (pow_ne_zero c PowerSeries.X_ne_zero) + have hinjective : Function.Injective + (residueMatrix (formalTangentMatrix q Z tau)).mulVec := + residue_formalTangentMatrix_mulVec_injective + q Z tau rows chart hqchart hZchart htauchart htauselected + hminor hprimitive + exact ⟨lambda, c, tau, hlambda, hselected, htauchart, htauselected, + hc, hfactor, hprimitive, hinjective⟩ + + +end + +end Stafford38.GeometryFormalDivisorTangent diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticConormal.lean new file mode 100644 index 0000000000..2e9a953951 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticConormal.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticLaurentAxis +import LeanPool.Stafford38.Stafford38.Geometry.SmoothConormalFibreVanishing +import LeanPool.Stafford38.Stafford38.Geometry.ConormalScalarExtensionVanishing + +/-! +# Asymptotic conormal directions of coordinate-avoiding varieties + +The boundary witness specializes only in the fibre coordinates. Its base +coordinates may have poles. Smooth-locus density and scalar-extension +vanishing relate that witness to the ground-field projective direction set. +-/ + +namespace Stafford38.Geometry.GeneralAsymptoticConormal + +open Stafford38.Geometry.GeneralAsymptoticLaurentAxis +open Stafford38.Geometry.SmoothConormalFibreVanishing +open Stafford38.Geometry.ProjectiveConormalDirections +open Stafford38.Geometry.ConormalScalarExtensionVanishing +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +theorem coordinate_axis_mem_smooth_fibre_closure + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : PrimeSpectrum (MvPolynomial (Fin m) k)) + (havoid : ∀ y ∈ MvPolynomial.zeroLocus k I.asIdeal, y ⟨0, hm⟩ ≠ 0) : + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) ∈ + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (smoothConormalFibreProjection I.asIdeal)) := by + obtain ⟨K, hK, hAlg, y, xi, hgeneric, hres⟩ := + exists_groundConormalAxis_of_prime_coordinate_avoidance hm I havoid + letI := hK + letI := hAlg + intro P hP + have hfull := fibreLift_mem_vanishingIdeal_equationConormal I.asIdeal I.isPrime P hP + have hvan : ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) I.asIdeal, + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q (fibreLift P) = 0 := by + letI : Algebra k (LaurentSeries K) := + (groundLaurentMap (k := k) (K := K)).toAlgebra + intro q hq + exact scalarExtension_vanishing I.asIdeal (fibreLift P) hfull q hq + have hpoly := residueFibreLift_mem_extensionValuedVanishingIdeal_of_ground_vanishing + I.asIdeal P hvan + have hclosure := residue_mem_residueExtensionFibreClosure_of_laurent_generic + (K := K) (groundEquationConormalLocus (k := k) (K := K) I.asIdeal) y xi hgeneric + have hzero := hclosure _ hpoly + have hzero' : MvPolynomial.eval₂ (algebraMap k K) (residueColumn xi) P = 0 := by + simpa [residuePolynomialMap] using hzero + rw [hres] at hzero' + apply (FaithfulSMul.algebraMap_injective k K) + rw [map_zero] + change (algebraMap k K) (MvPolynomial.eval + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) P) = 0 + rw [MvPolynomial.eval₂_comp] + simpa [Function.comp_def] using hzero' + +theorem coordinate_axis_mem_projective_conormal_directions + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : PrimeSpectrum (MvPolynomial (Fin m) k)) + (havoid : ∀ y ∈ MvPolynomial.zeroLocus k I.asIdeal, y ⟨0, hm⟩ ≠ 0) : + Projectivization.mk k + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) + (by intro h; have := congrFun h ⟨0, hm⟩; simpa using this) ∈ + projectiveHomogeneousClosure + (projectivizedDirectionSet (smoothConormalDirectionSet I.asIdeal)) := by + exact mk_mem_projectiveHomogeneousClosure_of_fibre_zeroLocus I.asIdeal _ _ + (coordinate_axis_mem_smooth_fibre_closure hm I havoid) + + +end +end Stafford38.Geometry.GeneralAsymptoticConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticLaurentAxis.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticLaurentAxis.lean new file mode 100644 index 0000000000..827b706627 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralAsymptoticLaurentAxis.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConstantCoordinateAxis +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoordinateAvoidance +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalConstantCoordinateBranch + +/-! +# Laurent conormal axes for coordinate-avoiding prime varieties + +This combines the constant-coordinate and divisorial cases for an arbitrary +prime affine ideal. The conclusion is a residue-extension Laurent witness; +its comparison with ground-field projective directions is separate. +-/ + +namespace Stafford38.Geometry.GeneralAsymptoticLaurentAxis + +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.GeneralConormalAxis +open Stafford38.Geometry.GeneralConstantCoordinateAxis +open Stafford38.Geometry.GeneralCoordinateAvoidance +open Stafford38.Geometry.CanonicalConstantCoordinateBranch +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +theorem exists_groundConormalAxis_of_prime_coordinate_avoidance + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (havoid : ∀ y ∈ MvPolynomial.zeroLocus k P.asIdeal, y ⟨0, hm⟩ ≠ 0) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin m → LaurentSeries K) (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) P.asIdeal ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + by_cases halg : IsAlgebraic k (componentCoordinate P ⟨0, hm⟩) + · obtain ⟨c, y, hc, hy, _⟩ := + exists_constant_coordinate_equation_and_pure_axis hm P halg + exact exists_residueExtensionConormalAxis_of_ambientCoordinate_constant + hm P.asIdeal ⟨y, hy⟩ ⟨c, hc⟩ + · apply exists_groundConormalAxis_of_minimalPrime_unit_transcendental + hm P.asIdeal P.isPrime.isRadical P + · simp [Ideal.minimalPrimes_eq_subsingleton_self] + · exact exists_coordinate_inverse_of_avoidance P.asIdeal ⟨0, hm⟩ havoid + · exact halg + + +end +end Stafford38.Geometry.GeneralAsymptoticLaurentAxis diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicCanonicalAdapter.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicCanonicalAdapter.lean new file mode 100644 index 0000000000..05bc815401 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicCanonicalAdapter.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalGabberInvolutivityInterface +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalLaurentSymbolControl +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalUnitCoordinatePreimage +import LeanPool.Stafford38.Stafford38.Characteristic.GabberGlobalAssembly +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdealHomogeneous +import LeanPool.Stafford38.Stafford38.Characteristic.ReducedSupportIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.ZeroSectionContainment +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction +import LeanPool.Stafford38.Stafford38.Geometry.FibreConicalVanishingIdeal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSets + +/-! +# Adapter from canonical order support to the arbitrary coisotropic theorem + +The canonical order support is presented on the prime spectrum, while the +general exclusion theorem is stated for field-valued phase points. This file +performs that change of presentation at the reduced order-support ideal. The +canonical support-avoidance input supplies the coordinate hypothesis, and the +Gabber involutivity result supplies the self-involutivity of the same radical +ideal. + +This adapter is deliberately separate from the canonical support assembly, so +the general theorem can be integrated there without an import cycle. +-/ + +namespace Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter + +open Stafford38 +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.CanonicalUnitCoordinatePreimage +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Characteristic.CanonicalLaurentSymbolControl +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.GabberGlobalAssembly +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Characteristic.ZeroSectionContainment +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.FibreConicalVanishingIdeal +open Stafford38.Geometry.GeneralCoisotropicSets +open Stafford38.Geometry.ConormalAxisContradiction +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.WeylEulerResidue +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBWMonicBridge +open Stafford38.EulerSurjectivity + +noncomputable section + +universe u + +variable {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + +local instance orderGradedAlgebraInstance {n : ℕ} : + GradedAlgebra + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n)) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +private theorem orderInitialIdeal_isHomogeneous + {n : ℕ} (I : RightIdeal (PresentedWeyl k n)) : + (orderInitialIdeal k I).IsHomogeneous + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n)) := by + intro d P hP + exact CharacteristicFilteredQuotient.coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k I d + (DirectSum.decompose + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n)) P d) + (decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k I P hP d) + +private theorem zeroLocus_isFibreConical_of_isHomogeneous + {n : ℕ} (J : Ideal (SymbolRing k n)) + (hhom : J.IsHomogeneous + (MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n))) : + IsFibreConical (MvPolynomial.zeroLocus k J) := by + intro q hq a ha + let y : Fin n → k := fun i => q (.inl i) + let ξ : Fin n → k := fun i => q (.inr i) + have hqsplit : q = Sum.elim y ξ := by + funext i + rcases i with i | i <;> rfl + have hline (f : SymbolRing k n) (hf : f ∈ J) : + fibreLinePolynomial y ξ f = 0 := by + apply Polynomial.ext + intro d + rw [coeff_fibreLinePolynomial_eq_eval_weightedHomogeneousComponent] + rw [← hqsplit] + exact (MvPolynomial.mem_zeroLocus_iff.mp hq) _ (hhom d hf) + intro f hf + have heval := eval_fibreLinePolynomial y ξ f a + rw [hline f hf, Polynomial.eval_zero] at heval + simpa [y, ξ] using heval.symm + +/-! The canonical reduced support ideal is an admissible input to the +general coisotropic exclusion theorem. The only geometric fact used here is +Gabber's involutivity of the radical associated graded annihilator; its +base-relative fragment is obtained by restricting the first bracket entry to +the base polynomial subring. -/ + +theorem algebraicallyClosedCanonicalSupportVanishing_of_generalCoisotropic + (hunit : CanonicalStrictUnitCoordinatePreimage.{u}) : + AlgebraicallyClosedCanonicalSupportVanishing.{u} := by + intro k _ _ _ n N d hN hd + let I := canonicalRightIdeal (presentedCoordinate k n) d N + let J : Ideal (SymbolRing k (n + 1)) := reducedOrderSupportIdeal k I + have hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) := by + exact canonical_orderCharacteristicSupport_disjoint_coordinate_zeroLocus_of_strictUnit + k n N (hunit k n N d hN hd) + by_contra hsupp + have hnonempty : (orderCharacteristicSupport k I).Nonempty := + Set.nonempty_iff_ne_empty.mpr hsupp + have hproper : J ≠ ⊤ := by + intro htop + obtain ⟨p, hp⟩ := hnonempty + have hpzero : p ∈ PrimeSpectrum.zeroLocus J := by + rw [← orderCharacteristicSupport_eq_zeroLocus_reduced k I] + exact hp + rw [htop] at hpzero + simpa using hpzero + have hrad : J.IsRadical := by + simpa only [J] using reducedOrderSupportIdeal_isRadical k I + have hhom : J.IsHomogeneous + (MvPolynomial.weightedHomogeneousSubmodule k + (@orderWeight (n + 1))) := by + simpa only [J, reducedOrderSupportIdeal] using + (orderInitialIdeal_isHomogeneous (k := k) I).radical + have hinv : IsInvolutive J := by + change IsInvolutive (orderInitialIdeal k I).radical + rw [← annihilator_orderAssociatedGradedModule] + exact associatedGraded_radical_isInvolutive (k := k) I + have hW : IsFibreConical (MvPolynomial.zeroLocus k J) := + zeroLocus_isFibreConical_of_isHomogeneous J hhom + have hnonemptyW : (MvPolynomial.zeroLocus k J).Nonempty := by + obtain ⟨M, hM, hJM⟩ := Ideal.exists_le_maximal J hproper + obtain ⟨q, hqM⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hM + refine ⟨q, ?_⟩ + rw [MvPolynomial.mem_zeroLocus_iff] + intro f hf + have hfM : f ∈ M := hJM hf + rw [hqM, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hfM + exact hfM + have hpoissonW : ∀ f ∈ MvPolynomial.vanishingIdeal k + (MvPolynomial.zeroLocus k J), + ∀ g ∈ MvPolynomial.vanishingIdeal k (MvPolynomial.zeroLocus k J), + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k + (MvPolynomial.zeroLocus k J) := by + intro f hf g hg + rw [MvPolynomial.vanishingIdeal_zeroLocus_eq_radical] at hf hg ⊢ + exact Ideal.le_radical (hinv f (hrad hf) g (hrad hg)) + obtain ⟨P, hP⟩ := exists_canonical_fibrePolynomial n N hd + have hPinitial : fibreLift P ∈ J := by + apply orderInitialIdeal_le_reducedOrderSupportIdeal k I + rw [hP] + exact canonical_orderPrincipalComponent_mem_initialIdeal k n N hd + have hPaxis : MvPolynomial.eval + (fun i : Fin (n + 1) => + if i = ⟨0, Nat.zero_lt_succ n⟩ then (1 : k) else 0) P = 1 := by + have hcanonical := canonical_orderPrincipalComponent_eval_pureMomentumAxis + n N hd + rw [← hP] at hcanonical + have heval := eval₂_fibreLift (K := k) P + (fun _ : Fin (n + 1) => (0 : k)) + (fun i : Fin (n + 1) => + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) + have hsplit : Sum.elim (fun _ : Fin (n + 1) => (0 : k)) + (fun i : Fin (n + 1) => + if i = ⟨0, Nat.zero_lt_succ n⟩ then 1 else 0) = + axisPoint k (.inr (0 : Fin (n + 1))) := by + funext i + rcases i with i | i + · simp [axisPoint] + · simp [axisPoint, Sum.inr.injEq] <;> rfl + rw [hsplit] at heval + simpa only [← MvPolynomial.aeval_def, MvPolynomial.aeval_eq_eval] using + heval.symm.trans hcanonical + obtain ⟨q, hq, hqcoord⟩ := + exists_zero_base_coordinate_of_isFibreConical + (k := k) (m := n + 1) (Nat.zero_lt_succ n) + (MvPolynomial.zeroLocus k J) hnonemptyW ⟨J, rfl⟩ hW hpoissonW P + (by + rw [MvPolynomial.vanishingIdeal_zeroLocus_eq_radical] + exact Ideal.le_radical hPinitial) + (by rw [hPaxis]; exact one_ne_zero) + have hqSupport : MvPolynomial.pointToPoint q ∈ + orderCharacteristicSupport k I := by + rw [orderCharacteristicSupport_eq_zeroLocus_reduced k I, + PrimeSpectrum.mem_zeroLocus] + intro f hf + change f ∈ MvPolynomial.vanishingIdeal k {q} + rw [MvPolynomial.mem_vanishingIdeal_singleton_iff] + exact (MvPolynomial.mem_zeroLocus_iff.mp hq) f hf + have hqCoordinate : MvPolynomial.pointToPoint q ∈ + PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1))) := by + rw [PrimeSpectrum.mem_zeroLocus] + intro f hf + change f ∈ MvPolynomial.vanishingIdeal k {q} + rw [MvPolynomial.mem_vanishingIdeal_singleton_iff, + Set.mem_singleton_iff.mp hf] + simpa using hqcoord + exact Set.disjoint_left.mp hdisjoint hqSupport hqCoordinate + +end +end Stafford38.Geometry.GeneralCoisotropicCanonicalAdapter diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicExclusion.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicExclusion.lean new file mode 100644 index 0000000000..f254bb5ec5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicExclusion.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralAsymptoticConormal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralComponentConormalContainment + +/-! +# Coisotropic exclusion for arbitrary homogeneous radical ideals + +A nonempty fibre-conical coisotropic zero locus contained in a fibre-only +symbol hypersurface transverse to the distinguished axis must meet the +coordinate hyperplane. +-/ + +namespace Stafford38.Geometry.GeneralCoisotropicExclusion + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.GeneralConormalContainment +open Stafford38.Geometry.GeneralComponentConormalContainment +open Stafford38.Geometry.GeneralAsymptoticConormal +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ProjectiveConormalDirections +open Stafford38.Geometry.SmoothAffineConormal + +noncomputable section + +universe u + +theorem exists_zero_base_coordinate + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (J : Ideal (SymbolRing k m)) (hproper : J ≠ ⊤) + (hrad : J.IsRadical) + (hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := m))) + (hpoisson : IsBaseRelativePoisson J) + (P : MvPolynomial (Fin m) k) (hP : fibreLift P ∈ J) + (haxis : MvPolynomial.eval + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) P ≠ 0) : + ∃ q ∈ MvPolynomial.zeroLocus k J, q (.inl ⟨0, hm⟩) = 0 := by + classical + by_contra hnone + push_neg at hnone + let B := J.comap (baseLift (k := k) (n := m)).toRingHom + obtain ⟨Q, hQ⟩ := Ideal.nonempty_minimalPrimes + (show B ≠ ⊤ from Ideal.comap_ne_top _ hproper) + let qprime : PrimeSpectrum (MvPolynomial (Fin m) k) := ⟨Q, hQ.1.1⟩ + have havoid : ∀ y ∈ MvPolynomial.zeroLocus k Q, y ⟨0, hm⟩ ≠ 0 := by + intro y hy + have hyB : ∀ f ∈ B, MvPolynomial.eval y f = 0 := by + intro f hf + exact hy f (hQ.1.2 hf) + have hzero : zeroSectionPoint y ∈ MvPolynomial.zeroLocus k J := + zeroSection_commonZero_of_isHomogeneous J hhom y hyB + exact hnone (zeroSectionPoint y) hzero + have hclosure := coordinate_axis_mem_smooth_fibre_closure hm qprime havoid + apply haxis + apply hclosure P + intro ξ hξ + obtain ⟨y, hysmooth, hconormal⟩ := hξ + have hy : y ∈ MvPolynomial.zeroLocus k Q := + smoothAffinePoint_mem_zeroLocus Q hysmooth + have hpoint : Sum.elim y ξ ∈ equationConormalClosure Q := by + intro f hf + exact hf (Sum.elim y ξ) ⟨hy, hconormal⟩ + have hJpoint := equationConormalClosure_minimalPrime_subset_zeroLocus + J hrad hhom hpoisson Q hQ hpoint + have hzero := hJpoint (fibreLift P) hP + simpa [fibreLift, MvPolynomial.eval_rename, Function.comp_def] using hzero + + +end +end Stafford38.Geometry.GeneralCoisotropicExclusion diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSets.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSets.lean new file mode 100644 index 0000000000..b0638deccd --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSets.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FibreConicalVanishingIdeal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicExclusion + +/-! +# Coisotropic sets and their vanishing ideals + +Closed affine sets are represented as common zero loci of polynomial ideals. +The vanishing ideal is radical, and its base contraction describes the base +projection of a closed fibre-conical set. +-/ + +namespace Stafford38.Geometry.GeneralCoisotropicSets + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ConormalPrincipalOpenDensity +open Stafford38.Geometry.GeneralConormalContainment +open Stafford38.Geometry.GeneralComponentConormalContainment +open Stafford38.Geometry.GeneralCoisotropicExclusion +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.SmoothAffineConormal + +noncomputable section + +variable {k : Type*} [Field k] [IsAlgClosed k] [CharZero k] {n : ℕ} + +theorem vanishingIdeal_isRadical (W : Set (PhaseVar n → k)) : + (MvPolynomial.vanishingIdeal k W).IsRadical := by + intro p hp + obtain ⟨m, hm⟩ := Ideal.mem_radical_iff.mp hp + intro q hq + have h := hm q hq + simpa only [map_pow] using eq_zero_of_pow_eq_zero + (show (MvPolynomial.aeval q p) ^ m = 0 by simpa only [map_pow] using h) + +theorem zeroLocus_vanishingIdeal_of_algebraic_closed + (W : Set (PhaseVar n → k)) + (hclosed : ∃ L : Ideal (SymbolRing k n), W = MvPolynomial.zeroLocus k L) : + MvPolynomial.zeroLocus k (MvPolynomial.vanishingIdeal k W) = W := by + obtain ⟨L, rfl⟩ := hclosed + apply Set.Subset.antisymm + · exact MvPolynomial.zeroLocus_anti_mono (MvPolynomial.le_vanishingIdeal_zeroLocus L) + · exact MvPolynomial.zeroLocus_vanishingIdeal_le _ + +theorem baseProjection_eq_zeroLocus_comap + (W : Set (PhaseVar n → k)) + (hclosed : ∃ L : Ideal (SymbolRing k n), W = MvPolynomial.zeroLocus k L) + (hhom : (MvPolynomial.vanishingIdeal k W).IsHomogeneous + (orderDecomposition (k := k) (n := n))) : + {y : Fin n → k | ∃ ξ : Fin n → k, Sum.elim y ξ ∈ W} = + MvPolynomial.zeroLocus k ((MvPolynomial.vanishingIdeal k W).comap baseLift) := by + ext y + constructor + · rintro ⟨ξ, hξ⟩ f hf + have h := hf (Sum.elim y ξ) hξ + simpa [baseLift, MvPolynomial.eval_rename, Function.comp_def] using h + · intro hy + refine ⟨0, ?_⟩ + rw [← zeroLocus_vanishingIdeal_of_algebraic_closed W hclosed] + have hzero := zeroSection_commonZero_of_isHomogeneous + (MvPolynomial.vanishingIdeal k W) hhom y hy + have hpoint : Sum.elim y (fun _ : Fin n => (0 : k)) = zeroSectionPoint y := by + funext i + rcases i with i | i <;> rfl + change Sum.elim y (fun _ : Fin n => (0 : k)) ∈ + MvPolynomial.zeroLocus k (MvPolynomial.vanishingIdeal k W) + rw [hpoint] + exact hzero + +/-- For every minimal component of the base projection, the closure of its +smooth conormal bundle lies in the original closed fibre-conical coisotropic +set. This is the set-level form of the component containment used in the +manuscript. -/ +theorem smoothConormalClosure_minimalPrime_subset_of_isFibreConical + (W : Set (PhaseVar n → k)) + (hclosed : ∃ L : Ideal (SymbolRing k n), + W = MvPolynomial.zeroLocus k L) + (hW : FibreConicalVanishingIdeal.IsFibreConical W) + (hpoisson : ∀ f ∈ MvPolynomial.vanishingIdeal k W, + ∀ g ∈ MvPolynomial.vanishingIdeal k W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k W) + (P : Ideal (MvPolynomial (Fin n) k)) + (hP : P ∈ ((MvPolynomial.vanishingIdeal k W).comap baseLift).minimalPrimes) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k + (restrictedEquationConormalLocus P {y | SmoothAffinePoint P y})) ⊆ W := by + let J : Ideal (SymbolRing k n) := MvPolynomial.vanishingIdeal k W + have hrad : J.IsRadical := by + simpa only [J] using vanishingIdeal_isRadical W + have hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := n)) := by + simpa only [J] using + FibreConicalVanishingIdeal.vanishingIdeal_isHomogeneous_of_isFibreConical W hW + have hbasePoisson : IsBaseRelativePoisson J := by + intro f hf g hg + exact hpoisson (baseLift f) hf g hg + rw [← zeroLocus_vanishingIdeal_of_algebraic_closed W hclosed] + exact smoothConormalClosure_minimalPrime_subset_zeroLocus + J hrad hhom hbasePoisson P hP + +/-- A nonempty closed fibre-conical coisotropic set cannot avoid the distinguished +base-coordinate hyperplane while lying in a fibre polynomial hypersurface +transverse to the distinguished axis. + +The ideal used by the argument is the actual vanishing ideal of `W`; its +radicality is automatic, fibre homogeneity is derived from `hW`, and +coisotropy means the exact self-involutivity condition `{I(W), I(W)} ⊆ I(W)`. -/ +theorem exists_zero_base_coordinate_of_isFibreConical + {k : Type*} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (W : Set (PhaseVar m → k)) + (hnonempty : W.Nonempty) + (hclosed : ∃ L : Ideal (SymbolRing k m), + W = MvPolynomial.zeroLocus k L) + (hW : FibreConicalVanishingIdeal.IsFibreConical W) + (hpoisson : ∀ f ∈ MvPolynomial.vanishingIdeal k W, + ∀ g ∈ MvPolynomial.vanishingIdeal k W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k W) + (P : MvPolynomial (Fin m) k) + (hP : fibreLift P ∈ MvPolynomial.vanishingIdeal k W) + (haxis : MvPolynomial.eval + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) P ≠ 0) : + ∃ q ∈ W, q (.inl ⟨0, hm⟩) = 0 := by + let J : Ideal (SymbolRing k m) := MvPolynomial.vanishingIdeal k W + have hproper : J ≠ ⊤ := by + intro htop + obtain ⟨q, hq⟩ := hnonempty + have hqzero : q ∈ MvPolynomial.zeroLocus k J := by + exact MvPolynomial.zeroLocus_vanishingIdeal_le W hq + rw [htop] at hqzero + simpa using hqzero + have hrad : J.IsRadical := by + simpa only [J] using vanishingIdeal_isRadical W + have hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := m)) := by + simpa only [J] using + FibreConicalVanishingIdeal.vanishingIdeal_isHomogeneous_of_isFibreConical W hW + have hbasePoisson : IsBaseRelativePoisson J := by + intro f hf g hg + exact hpoisson (baseLift f) hf g hg + obtain ⟨q, hq, hqcoord⟩ := exists_zero_base_coordinate hm J hproper hrad hhom + hbasePoisson P hP haxis + refine ⟨q, ?_, hqcoord⟩ + rw [← zeroLocus_vanishingIdeal_of_algebraic_closed W hclosed] + exact hq + + +end +end Stafford38.Geometry.GeneralCoisotropicSets diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSetsTest.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSetsTest.lean new file mode 100644 index 0000000000..b204733a9a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoisotropicSetsTest.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralCoisotropicSets +import LeanPool.Stafford38.Stafford38.Characteristic.PostScalarExtensionPoisson + +/-! +# Independent consumer for the set-level coisotropic exclusion + +The consumer statements use the exported set theorem as their only geometric +input. Their interface is paper-facing: closedness and nonemptiness are +hypotheses on `W`, while fibre homogeneity is supplied by `IsFibreConical` +rather than by an explicit homogeneous-ideal hypothesis. The additional +Poisson import supplies product rules for the independent negative control. +-/ + +namespace Stafford38.Geometry.GeneralCoisotropicSetsTest + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.PostScalarExtensionPoisson +open Stafford38.Geometry.FibreConicalVanishingIdeal +open Stafford38.Geometry.ConormalPrincipalOpenDensity +open Stafford38.Geometry.GeneralCoisotropicSets +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.SmoothAffineConormal + +noncomputable section + +universe u + +/-- The set-level component theorem exposes the manuscript's conormal +containment directly, without requiring a consumer to reconstruct the +vanishing-ideal dictionary. -/ +theorem exported_general_coisotropic_component_conormal_consumer + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} + (W : Set (PhaseVar m → k)) + (hclosed : ∃ L : Ideal (SymbolRing k m), + W = MvPolynomial.zeroLocus k L) + (hW : IsFibreConical W) + (hpoisson : ∀ f ∈ MvPolynomial.vanishingIdeal k W, + ∀ g ∈ MvPolynomial.vanishingIdeal k W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k W) + (P : Ideal (MvPolynomial (Fin m) k)) + (hP : P ∈ ((MvPolynomial.vanishingIdeal k W).comap + (Stafford38.Geometry.CoisotropicTranslation.baseLift : + MvPolynomial (Fin m) k →ₐ[k] SymbolRing k m).toRingHom).minimalPrimes) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k + (restrictedEquationConormalLocus P {y | SmoothAffinePoint P y})) ⊆ W := by + exact smoothConormalClosure_minimalPrime_subset_of_isFibreConical + W hclosed hW hpoisson P hP + +/-- The exported arbitrary-set theorem is consumable at exactly its stated +hypotheses, independently of the implementation module. -/ +theorem exported_general_coisotropic_set_consumer + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (W : Set (PhaseVar m → k)) + (hnonempty : W.Nonempty) + (hclosed : ∃ L : Ideal (SymbolRing k m), + W = MvPolynomial.zeroLocus k L) + (hW : IsFibreConical W) + (hpoisson : ∀ f ∈ MvPolynomial.vanishingIdeal k W, + ∀ g ∈ MvPolynomial.vanishingIdeal k W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k W) + (P : MvPolynomial (Fin m) k) + (hP : fibreLift P ∈ MvPolynomial.vanishingIdeal k W) + (haxis : MvPolynomial.eval + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) P ≠ 0) : + ∃ q ∈ W, q (.inl ⟨0, hm⟩) = 0 := by + exact exists_zero_base_coordinate_of_isFibreConical + hm W hnonempty hclosed hW hpoisson P hP haxis + +/-- The exclusion form used by the paper follows immediately and retains the +same arbitrary-set quantifiers. -/ +theorem false_of_exported_general_coisotropic_set_avoiding_hyperplane + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (W : Set (PhaseVar m → k)) + (hnonempty : W.Nonempty) + (hclosed : ∃ L : Ideal (SymbolRing k m), + W = MvPolynomial.zeroLocus k L) + (hW : IsFibreConical W) + (hpoisson : ∀ f ∈ MvPolynomial.vanishingIdeal k W, + ∀ g ∈ MvPolynomial.vanishingIdeal k W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal k W) + (P : MvPolynomial (Fin m) k) + (hP : fibreLift P ∈ MvPolynomial.vanishingIdeal k W) + (haxis : MvPolynomial.eval + (fun i : Fin m => if i = ⟨0, hm⟩ then (1 : k) else 0) P ≠ 0) + (havoid : ∀ q ∈ W, q (.inl ⟨0, hm⟩) ≠ 0) : + False := by + obtain ⟨q, hq, hqcoord⟩ := exported_general_coisotropic_set_consumer + hm W hnonempty hclosed hW hpoisson P hP haxis + exact havoid q hq hqcoord + +/-- The manuscript-facing statement over `ℂ`, with ordinary fibre scaling and +pointwise fibre-polynomial vanishing as its inputs. The exported theorem is +therefore checked through the definitions used by the paper rather than by +repeating its interface propositions as hypotheses. -/ +theorem exact_complex_manuscript_coisotropic_consumer + {n : ℕ} (hn : 0 < n) + (W : Set (PhaseVar n → ℂ)) + (hnonempty : W.Nonempty) + (hclosed : ∃ L : Ideal (SymbolRing ℂ n), + W = MvPolynomial.zeroLocus ℂ L) + (hscale : ∀ q ∈ W, ∀ a : ℂ, a ≠ 0 → + Sum.elim (fun i => q (.inl i)) (fun i => a * q (.inr i)) ∈ W) + (hbracket : ∀ f ∈ MvPolynomial.vanishingIdeal ℂ W, + ∀ g ∈ MvPolynomial.vanishingIdeal ℂ W, + poissonBracket f g ∈ MvPolynomial.vanishingIdeal ℂ W) + (P : MvPolynomial (Fin n) ℂ) + (hPpoint : ∀ q ∈ W, + MvPolynomial.eval (fun i => q (.inr i)) P = 0) + (haxis : MvPolynomial.eval + (fun i : Fin n => if i = ⟨0, hn⟩ then (1 : ℂ) else 0) P ≠ 0) + (havoid : ∀ q ∈ W, q (.inl ⟨0, hn⟩) ≠ 0) : + False := by + have hW : IsFibreConical W := hscale + have hP : fibreLift P ∈ MvPolynomial.vanishingIdeal ℂ W := by + rw [MvPolynomial.mem_vanishingIdeal_iff] + intro q hq + have hqP := hPpoint q hq + simpa [fibreLift, MvPolynomial.eval_rename, Function.comp_def] using hqP + exact false_of_exported_general_coisotropic_set_avoiding_hyperplane + hn W hnonempty hclosed hW hbracket P hP haxis havoid + +/-! ## A negative control for the coisotropic hypothesis + +The zero section in one-dimensional phase space has ideal `(ξ)`. It is +self-involutive, but it is not stable under bracketing with arbitrary ambient +polynomials because `{ξ, x} = -1`. -/ + +def zeroSectionIdealOne (k : Type*) [Field k] : Ideal (SymbolRing k 1) := + Ideal.span {MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1)} + +theorem zeroSectionIdealOne_isInvolutive + {k : Type*} [Field k] : + ∀ f ∈ zeroSectionIdealOne k, ∀ g ∈ zeroSectionIdealOne k, + poissonBracket f g ∈ zeroSectionIdealOne k := by + intro f hf g hg + change f ∈ Ideal.span + {MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1)} at hf + change g ∈ Ideal.span + {MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1)} at hg + rw [Ideal.mem_span_singleton] at hf hg + obtain ⟨a, ha⟩ := hf + obtain ⟨b, hb⟩ := hg + rw [ha, hb] + let I := zeroSectionIdealOne k + have hxi : MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1) ∈ I := + Ideal.mem_span_singleton_self _ + rw [PostScalarExtensionPoisson.poissonBracket_mul_left] + apply I.add_mem + · exact I.mul_mem_right _ hxi + · apply I.mul_mem_left + rw [PostScalarExtensionPoisson.poissonBracket_mul_right, + poissonBracket_self, mul_zero, add_zero] + exact I.mul_mem_right _ hxi + +theorem zeroSectionIdealOne_not_isPoisson + {k : Type*} [Field k] : ¬ IsPoisson (zeroSectionIdealOne k) := by + intro hpoisson + have hxi : MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1) ∈ + zeroSectionIdealOne k := + Ideal.mem_span_singleton_self _ + have hbad := hpoisson + (MvPolynomial.X (Sum.inr (0 : Fin 1) : PhaseVar 1)) hxi + (MvPolynomial.X (Sum.inl (0 : Fin 1) : PhaseVar 1)) + have hnegone : (-1 : SymbolRing k 1) ∈ zeroSectionIdealOne k := by + simpa [poissonBracket, Pi.single_apply] using hbad + rw [zeroSectionIdealOne, Ideal.mem_span_singleton] at hnegone + rcases hnegone with ⟨a, ha⟩ + have ha0 := congrArg + (MvPolynomial.eval (fun _ : PhaseVar 1 => (0 : k))) ha + simpa using ha0 + + +end +end Stafford38.Geometry.GeneralCoisotropicSetsTest diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralComponentConormalContainment.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralComponentConormalContainment.lean new file mode 100644 index 0000000000..7c410f8d5e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralComponentConormalContainment.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralConormalContainment +import LeanPool.Stafford38.Stafford38.Geometry.ConormalPrincipalOpenDensity +import LeanPool.Stafford38.Stafford38.Geometry.SmoothAffineConormal +import Mathlib.RingTheory.Ideal.MinimalPrime.Localization + +namespace Stafford38.Geometry.GeneralComponentConormalContainment + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.ConormalPrincipalOpenDensity +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.GeneralConormalContainment +open Stafford38.Geometry.SmoothAffineConormal +open Stafford38.WeylFiltration + +noncomputable section + +universe u + +variable {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] {n : ℕ} + +private theorem differentialCovector_mul (y : Fin n → k) + (p q : MvPolynomial (Fin n) k) : + differentialCovector y (p * q) = + MvPolynomial.eval y q • differentialCovector y p + + MvPolynomial.eval y p • differentialCovector y q := by + apply LinearMap.ext + intro v + change (∑ i, differentialAt y (p * q) i * v i) = + MvPolynomial.eval y q * (∑ i, differentialAt y p i * v i) + + MvPolynomial.eval y p * (∑ i, differentialAt y q i * v i) + simp only [differentialAt, MvPolynomial.pderiv_mul, map_add, map_mul, + Finset.mul_sum, ← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + ring + +private theorem exists_separator + (I P : Ideal (MvPolynomial (Fin n) k)) + (hI : I.IsRadical) (hP : P ∈ I.minimalPrimes) : + ∃ f ∉ P, ∀ h ∈ P, f * h ∈ I := by + classical + have hfin := Ideal.finite_minimalPrimes_of_isNoetherianRing + (MvPolynomial (Fin n) k) I + set T := hfin.toFinset.erase P with hT + have hchoice : ∀ Q ∈ T, ∃ s ∈ Q, s ∉ P := by + intro Q hQ + rw [hT, Finset.mem_erase, hfin.mem_toFinset] at hQ + by_contra hcon + push_neg at hcon + exact hQ.1 (le_antisymm hcon (hP.2 hQ.2.1 hcon)) + choose s hsQ hsP using hchoice + let f := ∏ Q ∈ T.attach, s Q.1 Q.2 + have hfP : f ∉ P := by + intro hf + obtain ⟨Q, -, hQ⟩ := (hP.1.1.prod_mem_iff).1 hf + exact hsP Q.1 Q.2 hQ + refine ⟨f, hfP, ?_⟩ + intro h hp + rw [← hI.radical, ← Ideal.sInf_minimalPrimes, Ideal.mem_sInf] + intro Q hQ + by_cases hQP : Q = P + · subst hQP + exact Ideal.mul_mem_left _ _ hp + · have hQT : Q ∈ T := by + rw [hT, Finset.mem_erase, hfin.mem_toFinset] + exact ⟨hQP, hQ⟩ + refine Ideal.mul_mem_right _ _ ?_ + exact Ideal.mem_of_dvd _ + (Finset.dvd_prod_of_mem (fun Q : T ↦ s Q.1 Q.2) + (Finset.mem_attach _ ⟨Q, hQT⟩)) + (hsQ Q hQT) + +theorem equationConormalClosure_minimalPrime_subset_zeroLocus + (J : Ideal (SymbolRing k n)) + (hJrad : J.IsRadical) + (hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := n))) + (hJpoisson : IsBaseRelativePoisson J) + (P : Ideal (MvPolynomial (Fin n) k)) + (hP : P ∈ (J.comap baseLift).minimalPrimes) : + equationConormalClosure P ⊆ MvPolynomial.zeroLocus k J := by + let I : Ideal (MvPolynomial (Fin n) k) := + J.comap (baseLift (k := k) (n := n)).toRingHom + have hIrad : I.IsRadical := by + exact Ideal.IsRadical.comap + (f := (baseLift (k := k) (n := n)).toRingHom) hJrad + change P ∈ I.minimalPrimes at hP + obtain ⟨f, hfP, hfp⟩ := exists_separator I P hIrad hP + let S : Set (Fin n → k) := {y | y ∈ MvPolynomial.zeroLocus k P ∧ + MvPolynomial.eval y f ≠ 0} + have hS : S ⊆ MvPolynomial.zeroLocus k P := by + intro y hy + exact hy.1 + have hopen : ∀ y : Fin n → k, y ∈ MvPolynomial.zeroLocus k P → + MvPolynomial.eval y f ≠ 0 → y ∈ S := by + intro y hy hfy + exact ⟨hy, hfy⟩ + have hrestricted : + ConormalPrincipalOpenDensity.restrictedEquationConormalLocus P S ⊆ + MvPolynomial.zeroLocus k J := by + intro q hq + let y : Fin n → k := fun i ↦ q (Sum.inl i) + let ξ : Fin n → k := fun i ↦ q (Sum.inr i) + have hyP : y ∈ MvPolynomial.zeroLocus k P := hq.2.1 + have hfy : MvPolynomial.eval y f ≠ 0 := hq.2.2 + have hyI : ∀ g ∈ I, MvPolynomial.eval y g = 0 := by + intro g hg + exact hq.1.1 g (hP.1.2 hg) + have hinc : affineConormalSpace y P ≤ affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan y P, + affineConormalSpace_eq_equationCovectorSpan y I] + apply Submodule.span_le.2 + intro z hz + rcases hz with ⟨h', rfl⟩ + rcases h' with ⟨h, hh⟩ + obtain hfh := hfp h hh + have hgen : differentialCovector y (f * h) ∈ + equationCovectorSpan y I := by + apply Submodule.subset_span + exact ⟨⟨f * h, hfh⟩, rfl⟩ + have hevalh : MvPolynomial.eval y h = 0 := hq.1.1 h hh + rw [differentialCovector_mul, hevalh, zero_smul, zero_add] at hgen + have hscaled := (equationCovectorSpan y I).smul_mem + (MvPolynomial.eval y f)⁻¹ hgen + rw [smul_smul, inv_mul_cancel₀ hfy, one_smul] at hscaled + exact hscaled + have hxiI : coordinateCovector ξ ∈ affineConormalSpace y I := + hinc hq.1.2 + have hqI : q ∈ equationConormalLocus I := ⟨hyI, hxiI⟩ + exact (GeneralConormalContainment.equationConormalLocus_subset_zeroLocus + J hJpoisson (fun z hz ↦ + zeroSection_commonZero_of_isHomogeneous J hhom z hz)) hqI + have hclosure := equationConormalClosure_restricted_eq P hP.1.1 f hfP S hS hopen + intro q hq + apply (zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (ConormalPrincipalOpenDensity.restrictedEquationConormalLocus P S) + J hrestricted) + rw [hclosure] + exact hq + +theorem smoothConormalClosure_minimalPrime_subset_zeroLocus + (J : Ideal (SymbolRing k n)) + (hJrad : J.IsRadical) + (hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := n))) + (hJpoisson : IsBaseRelativePoisson J) + (P : Ideal (MvPolynomial (Fin n) k)) + (hP : P ∈ (J.comap baseLift).minimalPrimes) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k + (restrictedEquationConormalLocus P {y | SmoothAffinePoint P y})) ⊆ + MvPolynomial.zeroLocus k J := by + rw [equationConormalClosure_smoothAffine_eq P hP.1.1] + exact equationConormalClosure_minimalPrime_subset_zeroLocus + J hJrad hhom hJpoisson P hP + + +end + +end Stafford38.Geometry.GeneralComponentConormalContainment diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalAxis.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalAxis.lean new file mode 100644 index 0000000000..e66e706e30 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalAxis.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralDivisorialVisibleFrame +import LeanPool.Stafford38.Stafford38.Geometry.FiniteGradientResidueExtension + +/-! +# Laurent conormal axes for arbitrary affine components + +The prime-component visible frame passes through the generic finite-gradient +adapter to a Laurent equation-conormal point with the prescribed residue. +This is an algebraic witness; the comparison with smooth projective conormal +directions is a separate statement. + + +## References and proof context + +[HTT08] Ryoshi Hotta, Kiyoshi Takeuchi, and Toshiyuki Tanisaki, *D-Modules, Perverse Sheaves, and Representation Theory*, Progress in Mathematics 236, Birkhäuser, 2008. +https://doi.org/10.1007/978-0-8176-4523-6 + +Chapters 1–2 supply characteristic-variety context. The visible-frame and finite-gradient construction is project mathematics, not a cited theorem from this book. See docs/literature.md. +-/ + +namespace Stafford38.Geometry.GeneralConormalAxis + +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.GeneralDivisorialVisibleFrame +open Stafford38.Geometry.ExactVisibleDivisorFrameInterface +open Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +open Stafford38.Geometry.FiniteGradientResidueExtension +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +theorem exists_groundConormalAxis_of_minimalPrime_unit_transcendental + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) (hI : I.IsRadical) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (hP : P.asIdeal ∈ I.minimalPrimes) + (hunit : ∃ g : MvPolynomial (Fin m) k, + MvPolynomial.X ⟨0, hm⟩ * g - 1 ∈ P.asIdeal) + (htrans : Transcendental k (componentCoordinate P ⟨0, hm⟩)) : + ∃ (K : Type u) (_ : Field K) (_ : Algebra k K) + (y : Fin m → LaurentSeries K) (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + have hframe := hasVisibleDivisorFrame_of_normalizedCompatibleVisibleFrame P hm + (generalDivisorialVisibleFrameExistence hm P hunit htrans) + obtain ⟨K, hK, hAlg, ⟨W⟩⟩ := + exists_finiteGradientBoundaryCertificateOver_of_hasVisibleDivisorFrame + I hI P hP hm hframe + letI := hK + letI := hAlg + obtain ⟨y, xi, hmem, hres⟩ := + exists_groundConormalAxis_of_finiteGradientBoundaryCertificateOver hm I W + exact ⟨K, hK, hAlg, y, xi, hmem, hres⟩ + + +end +end Stafford38.Geometry.GeneralConormalAxis diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalContainment.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalContainment.lean new file mode 100644 index 0000000000..633e28ffb0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConormalContainment.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure + +/-! +# Generic equation-conormal containment + +This is the support-independent form of the affine conormal argument. +Fibre-degree homogeneity supplies its zero-section input through the actual +Mathlib graded-ideal API. +-/ + +namespace Stafford38.Geometry.GeneralConormalContainment + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.WeylFiltration + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +abbrev orderDecomposition := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +instance orderGradedAlgebraInstance : + GradedAlgebra (orderDecomposition (k := k) (n := n)) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +private def basePart (g : SymbolRing k n) : MvPolynomial (Fin n) k := + MvPolynomial.eval₂Hom (MvPolynomial.C : k →+* MvPolynomial (Fin n) k) + (Sum.elim MvPolynomial.X (fun _ => 0)) g + +private theorem baseLift_basePart_eq_zeroComponent (g : SymbolRing k n) : + baseLift (basePart g) = + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) g 0 : + SymbolRing k n) := by + induction g using MvPolynomial.induction_on with + | C a => + have hC : MvPolynomial.C a ∈ orderDecomposition (k := k) (n := n) 0 := + MvPolynomial.isWeightedHomogeneous_C (@orderWeight n) a + let C0 : orderDecomposition (k := k) (n := n) 0 := ⟨MvPolynomial.C a, hC⟩ + have hd := congrArg (fun z => z 0) + (DirectSum.decompose_coe (orderDecomposition (k := k) (n := n)) C0) + have hd' : (DirectSum.decompose (orderDecomposition (k := k) (n := n)) + (MvPolynomial.C a) 0 : SymbolRing k n) = MvPolynomial.C a := by + simpa [C0] using congrArg Subtype.val hd + rw [hd'] + simp [basePart] + | add P Q hP hQ => + rw [DirectSum.decompose_add] + change baseLift (basePart (P + Q)) = + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) P 0 : + SymbolRing k n) + + (DirectSum.decompose (orderDecomposition (k := k) (n := n)) Q 0 : + SymbolRing k n) + rw [← hP, ← hQ] + simp [basePart] + | mul_X P i hP => + rcases i with i | i + · have hX : MvPolynomial.X (Sum.inl i : PhaseVar n) ∈ + orderDecomposition (k := k) (n := n) 0 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) _ + rw [DirectSum.coe_decompose_mul_of_right_mem_of_le + (orderDecomposition (k := k) (n := n)) hX (Nat.zero_le 0)] + rw [← hP] + simp [basePart, baseLift] + · have hX : MvPolynomial.X (Sum.inr i : PhaseVar n) ∈ + orderDecomposition (k := k) (n := n) 1 := + MvPolynomial.isWeightedHomogeneous_X k (@orderWeight n) _ + rw [DirectSum.coe_decompose_mul_of_right_mem_of_not_le + (orderDecomposition (k := k) (n := n)) hX (by omega)] + simp [basePart] + +private theorem eval_basePart (y : Fin n → k) (g : SymbolRing k n) : + MvPolynomial.eval y (basePart g) = + MvPolynomial.eval (zeroSectionPoint y) g := by + induction g using MvPolynomial.induction_on with + | C a => simp [basePart] + | add P Q hP hQ => + simp only [basePart] at hP hQ + simp only [basePart, map_add] + rw [hP, hQ] + | mul_X P i hP => + rcases i with i | i + · simp only [basePart, map_mul, MvPolynomial.eval₂Hom_X', Sum.elim_inl, + MvPolynomial.eval_X] + simp only [basePart] at hP + rw [hP] + simp [zeroSectionPoint] + · simp [basePart, zeroSectionPoint] + +theorem zeroSection_commonZero_of_isHomogeneous + (J : Ideal (SymbolRing k n)) + (hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := n))) + (y : Fin n → k) + (hy : ∀ f ∈ J.comap baseLift, MvPolynomial.eval y f = 0) : + ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0 := by + intro g hg + let f := basePart g + have hf : baseLift f ∈ J := by + rw [baseLift_basePart_eq_zeroComponent] + exact (hhom.mem_iff.mp hg 0) + have hzero := hy f hf + rw [eval_basePart] at hzero + exact hzero + +/-- The equation-defined conormal over `V(J.comap baseLift)` is contained in +`V(J)`, provided the zero section over every base zero is a common zero of +`J`. This is the exact generic bridge; no characteristic-support predicate +or radicality assumption is used here. -/ +theorem equationConormalLocus_subset_zeroLocus + [CharZero k] + (J : Ideal (SymbolRing k n)) + (hJ : IsBaseRelativePoisson J) + (hzero : ∀ y : Fin n → k, + (∀ f ∈ J.comap baseLift, MvPolynomial.eval y f = 0) → + ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) : + equationConormalLocus (J.comap baseLift) ⊆ + MvPolynomial.zeroLocus k J := by + intro q hq + let y : Fin n → k := fun i => q (Sum.inl i) + let ξ : Fin n → k := fun i => q (Sum.inr i) + have hy : ∀ f ∈ J.comap baseLift, MvPolynomial.eval y f = 0 := by + intro f hf + exact hq.1 f hf + have hs := affineConormal_coordinatePoint_isCommonZero J hJ y + (hzero y hy) (J.comap baseLift) + (fun f => f.2) ξ hq.2 + have hsplit : Sum.elim y ξ = q := by + funext i + rcases i with i | i <;> rfl + rw [← hsplit] + exact hs + +theorem equationConormalClosure_subset_zeroLocus + [CharZero k] + (J : Ideal (SymbolRing k n)) + (hJ : IsBaseRelativePoisson J) + (hzero : ∀ y : Fin n → k, + (∀ f ∈ J.comap baseLift, MvPolynomial.eval y f = 0) → + ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) : + equationConormalClosure (J.comap baseLift) ⊆ + MvPolynomial.zeroLocus k J := by + exact zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (equationConormalLocus (J.comap baseLift)) J + (equationConormalLocus_subset_zeroLocus J hJ hzero) + +/-- Fibre-homogeneity supplies the zero-section input required by the generic +conormal argument. -/ +theorem equationConormalClosure_subset_zeroLocus_of_isHomogeneous + [CharZero k] + (J : Ideal (SymbolRing k n)) + (hhom : J.IsHomogeneous (orderDecomposition (k := k) (n := n))) + (hJ : IsBaseRelativePoisson J) : + equationConormalClosure (J.comap baseLift) ⊆ + MvPolynomial.zeroLocus k J := by + apply equationConormalClosure_subset_zeroLocus J hJ + intro y hy + exact zeroSection_commonZero_of_isHomogeneous J hhom y hy + + +end + +end Stafford38.Geometry.GeneralConormalContainment diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralConstantCoordinateAxis.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConstantCoordinateAxis.lean new file mode 100644 index 0000000000..11b0fa5306 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralConstantCoordinateAxis.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineComponentCoordinateSplit +import LeanPool.Stafford38.Stafford38.Geometry.ConstantCoordinateConormal +import Mathlib.RingTheory.Nullstellensatz + +namespace Stafford38.Geometry.GeneralConstantCoordinateAxis + +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.ConstantCoordinateConormal + +noncomputable section + +universe u + +theorem exists_constant_coordinate_equation_and_pure_axis + {k : Type u} [Field k] [IsAlgClosed k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (halg : IsAlgebraic k (componentCoordinate P ⟨0, hm⟩)) : + ∃ (c : k) (y : Fin m → k), + MvPolynomial.X ⟨0, hm⟩ - MvPolynomial.C c ∈ P.asIdeal ∧ + (∀ f ∈ P.asIdeal, MvPolynomial.eval y f = 0) ∧ + Sum.elim y (fun j ↦ if j = ⟨0, hm⟩ then 1 else 0) ∈ + Stafford38.Geometry.AffineConormalClosure.equationConormalLocus + P.asIdeal := by + obtain ⟨c, hc⟩ | htrans := + coordinate_constant_or_transcendental P ⟨0, hm⟩ + · obtain ⟨M, hMmax, hPM⟩ := Ideal.exists_le_maximal P.asIdeal P.isPrime.ne_top + obtain ⟨y, hMy⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hMmax + have hy : ∀ f ∈ P.asIdeal, MvPolynomial.eval y f = 0 := by + intro f hf + have hfM : f ∈ M := hPM hf + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hfM + exact hfM + refine ⟨c, y, hc, hy, ?_⟩ + exact constantCoordinate_phasePoint_mem_equationConormalLocus + P.asIdeal y hy ⟨0, hm⟩ c hc + · exact False.elim (htrans halg) + + +end + +end Stafford38.Geometry.GeneralConstantCoordinateAxis diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoordinateAvoidance.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoordinateAvoidance.lean new file mode 100644 index 0000000000..98677c8191 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralCoordinateAvoidance.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Nullstellensatz + +/-! +# Polynomial inverses from coordinate avoidance + +A coordinate that never vanishes on an affine zero locus is invertible modulo +its defining ideal. The ideal need not be prime or radical. +-/ + +namespace Stafford38.Geometry.GeneralCoordinateAvoidance + +noncomputable section + +theorem exists_coordinate_inverse_of_avoidance + {k : Type*} [Field k] [IsAlgClosed k] {m : ℕ} + (I : Ideal (MvPolynomial (Fin m) k)) (i : Fin m) + (havoid : ∀ y ∈ MvPolynomial.zeroLocus k I, y i ≠ 0) : + ∃ g : MvPolynomial (Fin m) k, MvPolynomial.X i * g - 1 ∈ I := by + classical + let J := I ⊔ Ideal.span ({MvPolynomial.X i} : Set (MvPolynomial (Fin m) k)) + have htop : J = ⊤ := by + by_contra hne + obtain ⟨M, hM, hJM⟩ := Ideal.exists_le_maximal J hne + obtain ⟨y, hMy⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hM + have hy : y ∈ MvPolynomial.zeroLocus k I := by + intro p hp + have hpM := hJM (show p ∈ J from Ideal.mem_sup_left hp) + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hpM + exact hpM + have hxM : MvPolynomial.X i ∈ M := + hJM (Ideal.mem_sup_right (Ideal.mem_span_singleton_self _)) + rw [hMy, MvPolynomial.mem_vanishingIdeal_singleton_iff] at hxM + exact havoid y hy (by simpa using hxM) + have hone : (1 : MvPolynomial (Fin m) k) ∈ J := by simp [htop] + obtain ⟨b, hb, z, hz, hbz⟩ := Submodule.mem_sup.mp hone + obtain ⟨g, hg⟩ := Ideal.mem_span_singleton.mp hz + refine ⟨g, ?_⟩ + have heq : MvPolynomial.X i * g - 1 = -b := by + rw [← hg] + rw [← hbz] + ring + rw [heq] + exact I.neg_mem hb + + +end +end Stafford38.Geometry.GeneralCoordinateAvoidance diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralDivisorialVisibleFrame.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralDivisorialVisibleFrame.lean new file mode 100644 index 0000000000..cf79cb4c32 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralDivisorialVisibleFrame.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ExactDivisorialVisibleFrameExistence + +/-! +# Divisorial visible frames for arbitrary prime affine components + +An invertible, transcendental coordinate on a prime affine component gives +a normalized visible divisor frame. This removes the canonical Weyl-support +hypotheses from the boundary producer. Identification of the resulting Laurent +direction with the smooth projective conormal closure is performed downstream +in the general asymptotic-conormal construction. +-/ + +namespace Stafford38.Geometry.GeneralDivisorialVisibleFrame + +open IsLocalRing Polynomial +open Stafford38 +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveOrder +open Stafford38.Geometry.ExactDivisorialVisibleFrameExistence +open Stafford38.Geometry.ExactVisibleDivisorFrameInterface +open Stafford38.Geometry.KaehlerDVRVisibility +open Stafford38.Geometry.ProjectiveDivisorOrderGap +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedDVR +open Stafford38.Geometry.DivisorTangentLattice + +noncomputable section + + +universe u + +/-- A polynomial inverse modulo the prime component forces the normalized +projective denominator to vanish at the retained boundary place. The visible +differential frame is then supplied by the generic divisorial construction. -/ +theorem generalDivisorialVisibleFrameExistence + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (hunit : ∃ g : MvPolynomial (Fin m) k, + MvPolynomial.X ⟨0, hm⟩ * g - 1 ∈ P.asIdeal) + (htrans : Transcendental k + (componentCoordinate P ⟨0, hm⟩)) : + HasNormalizedCompatibleVisibleFrame P hm := by + let i : Fin m := ⟨0, hm⟩ + let K := ComponentFractionField P + obtain ⟨E, V, hEV, hVdvr, hxV, htransE, hxm, hEfin, hkaehler, halgAll⟩ := + Stafford38.Geometry.LaneC.divisorialVisibleFrameExistence + k K m (componentCoordinate P) i + (componentCoordinate_adjoin_eq_top P) htrans + letI : IsLocalRing V.toSubring := hVdvr.toIsLocalRing + letI : Algebra E V.toSubring := + (Stafford38.Geometry.LaneC.coeffHom E V hEV).toAlgebra + letI : Algebra k V.toSubring := + (Stafford38.Geometry.LaneC.groundHom E V hEV).toAlgebra + letI : Algebra V.toSubring K := V.toSubring.subtype.toAlgebra + letI : IsScalarTower k V.toSubring K := + IsScalarTower.of_algebraMap_eq fun c => by + change algebraMap k K c = (algebraMap k E c : K) + exact IsScalarTower.algebraMap_apply k E K c + letI : Module.Finite V.toSubring (Ω[V.toSubring⁄k]) := hkaehler + let W : Data k K (componentCoordinate P i) := + retainedDataOfValuation E V hEV hVdvr (componentCoordinate P i) hxV + htransE hxm hEfin + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + obtain ⟨chart, qraw, scale, hscale, hchartRaw, hqraw⟩ := + exists_normalized_projective_lift V (componentProjectivePoint P) + ⟨0, by simp [componentProjectivePoint]⟩ + let q : Fin (m + 1) → V.toSubring := fun a => + ⟨qraw a, (qraw a).property⟩ + have hchart : q chart = 1 := by + apply Subtype.ext + exact congrArg Subtype.val hchartRaw + have hq : ∀ a, (q a : K) = scale * componentProjectivePoint P a := by + intro a + exact hqraw a + have hq0 : q 0 ≠ 0 := by + intro hzero + apply hscale + have h := hq 0 + rw [hzero] at h + simpa [componentProjectivePoint] using h.symm + let xV : V.toSubring := ⟨componentCoordinate P i, hxV⟩ + have hratioV : q (Fin.succ i) = q 0 * xV := by + apply Subtype.ext + change (q (Fin.succ i) : K) = (q 0 : K) * componentCoordinate P i + rw [hq, hq] + simp [componentProjectivePoint] + have hq0nonunit : ¬ IsUnit (q 0) := by + obtain ⟨g, hg⟩ := hunit + let F := K + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) F := + W.ambientAlgebra + letI : IsScalarTower W.coefficientField + (CoordinateZeroLocalRing W.coefficientField) F := W.coefficientTower + let phi : MvPolynomial (Fin m) k →+* F := + (algebraMap (MvPolynomial (Fin m) k ⧸ P.asIdeal) F).comp + (Ideal.Quotient.mk P.asIdeal) + have hphiC : phi.comp MvPolynomial.C = algebraMap k F := by + ext c + exact IsScalarTower.algebraMap_apply k + (MvPolynomial (Fin m) k ⧸ P.asIdeal) F c + have hphiX : ∀ j, phi (MvPolynomial.X j) = componentCoordinate P j := by + intro j + rfl + have hpoly : phi g = MvPolynomial.eval₂ (algebraMap k F) + (fun j ↦ componentCoordinate P j) g := by + rw [MvPolynomial.map_mvPolynomial_eq_eval₂ phi g] + change MvPolynomial.eval₂Hom (phi.comp MvPolynomial.C) + (fun j ↦ phi (MvPolynomial.X j)) g = + MvPolynomial.eval₂Hom (algebraMap k F) + (fun j ↦ componentCoordinate P j) g + apply MvPolynomial.eval₂Hom_congr hphiC + · funext j + exact hphiX j + · rfl + have hinverse : componentCoordinate P i * + MvPolynomial.eval₂ (algebraMap k F) + (fun j ↦ componentCoordinate P j) g = 1 := by + have hzero : phi (MvPolynomial.X i * g - 1) = 0 := by + have hmk : Ideal.Quotient.mk P.asIdeal + (MvPolynomial.X i * g - 1) = 0 := + Ideal.Quotient.eq_zero_iff_mem.mpr hg + simpa [phi] using (congrArg + (algebraMap (MvPolynomial (Fin m) k ⧸ P.asIdeal) F) hmk) + rw [map_sub, map_mul, map_one, sub_eq_zero, hphiX, hpoly] at hzero + exact hzero + let coeff : k →+* V := + (relativeCoefficientMap W.coefficientField W.place).comp + (algebraMap k W.coefficientField) + have hcoeff : W.place.valuation.toSubring.subtype.comp coeff = + algebraMap k F := by + ext c + change ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : F) = algebraMap k F c + calc + ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : F) = + algebraMap W.coefficientField F + (algebraMap k W.coefficientField c) := + DFunLike.congr_fun + (relativeCoefficientMap_commutes W.coefficientField W.place) + (algebraMap k W.coefficientField c) + _ = algebraMap k F c := + IsScalarTower.algebraMap_apply k W.coefficientField F c + exact normalized_denominator_nonunit_of_polynomial_inverse + (V := W.place.valuation) (coeff := coeff) hcoeff + (x := fun j ↦ componentCoordinate P j) + (qzero := q 0) (q := fun j ↦ q (Fin.succ j)) (scale := scale) + (i := i) (parameter := W.place.parameter) (g := g) + (by simpa [componentProjectivePoint] using hq 0) + (by intro j; simpa [componentProjectivePoint] using hq (Fin.succ j)) + W.parameter_eq_coordinate W.place.parameter_nonunit hinverse + have halg := halgAll scale q hq ⟨chart, hchart⟩ hq0nonunit + have hchart_ne : chart ≠ 0 := by + intro hzero + apply hq0nonunit + rw [← hzero, hchart] + exact isUnit_one + obtain ⟨j₀, rfl⟩ := Fin.exists_succ_eq_of_ne_zero hchart_ne + obtain ⟨t, ht⟩ := IsDiscreteValuationRing.exists_irreducible V.toSubring + have hq0max : q 0 ∈ maximalIdeal V.toSubring := by + apply (IsLocalRing.mem_maximalIdeal (q 0)).2 + exact mem_nonunits_iff.mpr hq0nonunit + have hxV_ne : xV ≠ 0 := by + intro hx0 + apply htransE + have hx0K : componentCoordinate P i = 0 := congrArg Subtype.val hx0 + exact hx0K ▸ isAlgebraic_zero + obtain ⟨a, e, b, u₀, ur, u₁, ha, he, hb, hab, + hq0factor, hparameterFactor, hu₁, hq1factor⟩ := + exists_uniformizer_strict_orderGap t ht (q 0) xV + (q (Fin.succ i)) hq0 hxV_ne hq0max hxm hratioV + let Q : Fin m → V.toSubring := fun j => q (Fin.succ j) + have hQj₀ : Q j₀ = 1 := hchart + have hq0frame : q 0 = t ^ a * (u₀ : V.toSubring) := by + simpa [mul_comm] using hq0factor + have hq1frame : q (Fin.succ i) = t ^ (a + e) * (u₁ : V.toSubring) := by + simpa [hb, mul_comm] using hq1factor + obtain ⟨D, hD0, hD1, hDt, hDu, hDw, hDQ, hDa, hDe, hDj, hDW⟩ := + exists_visibleDivisorFrame_of_kaehler_image + (k := k) (F := K) (q 0) (q (Fin.succ i)) t + (u₀ : V.toSubring) (u₁ : V.toSubring) Q a e j₀ + ht.maximalIdeal_eq ht.ne_zero u₀.isUnit + (Nat.one_le_iff_ne_zero.mpr ha.ne') + (Nat.one_le_iff_ne_zero.mpr he.ne') hq0frame hq1frame hQj₀ halg + refine ⟨W, Fin.succ j₀, q, scale, hscale, hchart, hq0, hq, ?_, ?_⟩ + · apply Subtype.ext + have hv := congrArg Subtype.val hratioV + change (q (Fin.succ ⟨0, hm⟩) : K) = + (q 0 : K) * componentCoordinate P ⟨0, hm⟩ at hv + calc + (q (Fin.succ ⟨0, hm⟩) : K) = + (q 0 : K) * componentCoordinate P ⟨0, hm⟩ := hv + _ = (q 0 : K) * (W.place.parameter : K) := by + rw [W.parameter_eq_coordinate] + · exact ⟨D, hD0, hD1, fun j => by rw [hDQ]⟩ + + +end + +end Stafford38.Geometry.GeneralDivisorialVisibleFrame diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLatticePresentation.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLatticePresentation.lean new file mode 100644 index 0000000000..0c6b2bcd44 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLatticePresentation.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Module.SplitLatticePresentation + +/-! Compatibility exports for the neutral split-lattice presentation. -/ + +namespace Stafford38.Geometry.GeneralTangentLatticePresentation + +export AlgebraicAnalysis.SplitLatticePresentation + (SplitMatrixPresentation exists_splitMatrixPresentation + exists_splitMatrixPresentation_of_isComplemented) + +end Stafford38.Geometry.GeneralTangentLatticePresentation diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterion.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterion.lean new file mode 100644 index 0000000000..1e4054fc63 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterion.lean @@ -0,0 +1,575 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDehomogenization +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection +import LeanPool.Stafford38.Stafford38.Geometry.SmoothAffineConormal +import LeanPool.Stafford38.Stafford38.Geometry.ConormalScalarExtensionVanishing +import LeanPool.Stafford38.Stafford38.Geometry.SmoothConormalFibreVanishing +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDirections +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorLaurentConormal +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLatticePresentation +import LeanPool.Stafford38.Stafford38.Geometry.LocalizedProjectiveChartTransition + +/-! +# The split-lattice tangent-limit calculation + +This file records the tangent-limit criterion after the affine-chart and +tangent-lattice dictionaries have been made explicit. It uses no +normalization theorem. A +power-series matrix is the lattice of projective tangent columns. A left +inverse is the direct-summand certificate. The axis condition is imposed on +the reduced lattice, and the annihilator is constructed by the retraction +correction; it is not an input. + +The Laurent-valued smooth equation-conormal direction hull is transported to +the ground-field projective closure by the existing scalar-extension and +smooth-fibre vanishing theorems. `Input` is the internal split-matrix kernel. +The paper-facing `DirectSummandInput` instead takes the formal arc and the +actual complemented tangent lattice. The theorem below constructs the +matrix presentation and proves the projective-closure and tangent-chart +dictionaries before applying that kernel. +-/ + +namespace Stafford38.Geometry.GeneralTangentLimitCriterion + +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.ConormalScalarExtensionVanishing +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ProjectiveConormalDirections +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.Geometry.SmoothAffineConormal +open Stafford38.Geometry.SmoothConormalFibreVanishing +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.GeneralTangentLatticePresentation +open Stafford38.Geometry.LocalizedProjectiveChartTransition +open Stafford38.Geometry.ProjectiveEquationFormalChart +open Stafford38.GeometryPowerSeriesTangentLimit +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {k : Type*} [Field k] + +/-- The scalar-extended smooth equation-conormal phase locus used by the +Laurent specialization theorem. The smoothness predicate is the genuine +`SmoothAffinePoint` predicate; it is not a dimension label or a placeholder. +-/ +def smoothEquationConormalLocus {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) : + Set (PhaseVar n → LaurentSeries k) := + {q | q ∈ equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) ∧ + SmoothAffinePoint + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (fun i ↦ q (Sum.inl i))} + +/-! ## Coordinate-free statement of the paper hypotheses -/ + +/-- Coordinatewise extension of scalars on a finite coordinate module. -/ +def extendColumn {R K : Type*} [CommSemiring R] [CommSemiring K] + [Algebra R K] {ι : Type*} : + (ι → R) →ₛₗ[algebraMap R K] (ι → K) where + toFun v i := algebraMap R K (v i) + map_add' x y := by ext i; simp + map_smul' a x := by ext i; simp + +/-- The ordinary scalar extension of a lattice, presented as the span of its +coordinatewise images. This definition avoids choosing a basis. -/ +def genericFibre {R K : Type*} [CommSemiring R] [CommSemiring K] + [Algebra R K] {ι : Type*} (L : Submodule R (ι → R)) : + Submodule K (ι → K) := + Submodule.span K (extendColumn (R := R) (K := K) '' (L : Set (ι → R))) + +/-- The derivative of the zeroth affine chart at a homogeneous point. -/ +def dehomogenizedTangentLinearMap {K : Type*} [Field K] {n : ℕ} + (q : Fin (n + 1) → K) : + (Fin (n + 1) → K) →ₗ[K] (Fin n → K) where + toFun w := dehomogenizedTangentColumn q w + map_add' x y := by + ext i + simp [dehomogenizedTangentColumn] + ring + map_smul' a x := by + ext i + simp [dehomogenizedTangentColumn] + ring + +/-- The affine cone over the embedded projective tangent plane in the chart +`q 0 ≠ 0`: it is the inverse image of the affine tangent space under the +chart derivative. Its radial kernel contains `q`. -/ +def projectiveTangentCone {K : Type*} [Field K] {n : ℕ} + (q : Fin (n + 1) → K) (T : Submodule K (Fin n → K)) : + Submodule K (Fin (n + 1) → K) := + T.comap (dehomogenizedTangentLinearMap q) + +/-- Equation-level membership in the projective closure in the zeroth chart. +The equations are the standard homogenizations of every affine equation, so +this is the ordinary homogeneous-equation presentation of the closure. -/ +def projectiveClosureAtZero {K : Type*} [Field K] {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) K)) + (q : Fin (n + 1) → K) : Prop := + ∀ f ∈ I, MvPolynomial.eval q (homogenizeAtZero f) = 0 + +/-- In the nonzero zeroth chart, the homogeneous-equation presentation of the +projective closure is equivalent to membership in the original affine zero +locus. -/ +theorem projectiveClosureAtZero_iff {K : Type*} [Field K] {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) K)) + (q : Fin (n + 1) → K) (hq0 : q 0 ≠ 0) : + projectiveClosureAtZero I q ↔ + dehomogenizedPoint q ∈ MvPolynomial.zeroLocus K I := by + constructor + · intro h f hf + have heval := eval_projectiveDehomogenize_eq_zero_of_homogeneous + (homogenizeAtZero f) f.totalDegree + (homogenizeAtZero_isHomogeneous f) q hq0 (h f hf) + simpa only [projectiveDehomogenize_homogenizeAtZero, + MvPolynomial.aeval_eq_eval] using heval + · intro h f hf + have hnormalized : + MvPolynomial.eval (normalizedProjectivePoint q (q 0)) + (homogenizeAtZero f) = 0 := by + rw [normalizedProjectivePoint_eq_chartPoint q hq0, + ← eval_projectiveDehomogenize, + projectiveDehomogenize_homogenizeAtZero] + exact h f hf + rw [eval_eq_pow_mul_eval_normalizedProjectivePoint + (homogenizeAtZero f) f.totalDegree + (homogenizeAtZero_isHomogeneous f) q (q 0) hq0, + hnormalized, mul_zero] + +/-- A formal projective arc represented by power-series coordinates. The +unit-coordinate condition makes the tuple a morphism to projective space; +the second field is membership in the homogeneous-equation closure after +passing to the generic Laurent point. -/ +def FormalProjectiveArcInClosure {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) : Prop := + (∃ i, IsUnit (q i)) ∧ + projectiveClosureAtZero + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (laurentColumn q) + +/-- Exact chart dictionary for `FormalProjectiveArcInClosure`: its +homogeneous projective equations are equivalent to the affine equations at +the Laurent generic point, while the unit-coordinate condition records that +the tuple is a genuine formal projective arc. -/ +theorem formalProjectiveArcInClosure_iff {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) : + FormalProjectiveArcInClosure I q ↔ + (∃ i, IsUnit (q i)) ∧ + dehomogenizedPoint (laurentColumn q) ∈ + MvPolynomial.zeroLocus (LaurentSeries k) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) := by + rw [FormalProjectiveArcInClosure, + projectiveClosureAtZero_iff] + exact laurentColumn_ne_zero_of_ne_zero q hq0 + +/-- The columns of a matrix presentation span the generic fibre of the +original lattice after scalar extension. -/ +private theorem genericFibre_eq_span_matrixColumns + {R K : Type*} [CommRing R] [Field K] [Algebra R K] + {ι κ : Type*} [Fintype κ] + (L : Submodule R (ι → R)) (B : Matrix ι κ R) + (hspan : Submodule.span R (Set.range fun j => fun i => B i j) = L) : + genericFibre (K := K) L = + Submodule.span K (Set.range fun j => fun i => + algebraMap R K (B i j)) := by + let f := extendColumn (R := R) (K := K) (ι := ι) + let columns : κ → (ι → R) := fun j i => B i j + apply le_antisymm + · apply Submodule.span_le.mpr + rintro _ ⟨x, hx, rfl⟩ + have hxspan : x ∈ Submodule.span R (Set.range columns) := by + rw [hspan] + exact hx + obtain ⟨c, hc⟩ := + (Submodule.mem_span_range_iff_exists_fun R).mp hxspan + apply (Submodule.mem_span_range_iff_exists_fun K).mpr + refine ⟨fun j => algebraMap R K (c j), ?_⟩ + apply funext + intro i + simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul] + have hi : (∑ j, c j * B i j) = x i := by + simpa only [columns, Finset.sum_apply, Pi.smul_apply, + smul_eq_mul] using congrFun hc i + change _ = algebraMap R K (x i) + simpa only [map_sum, map_mul] using congrArg (algebraMap R K) hi + · apply Submodule.span_le.mpr + rintro _ ⟨j, rfl⟩ + apply Submodule.subset_span + refine ⟨columns j, ?_, rfl⟩ + rw [← hspan] + exact Submodule.subset_span ⟨j, rfl⟩ + +/-- The chart derivative is onto whenever the chart denominator is nonzero. -/ +private theorem dehomogenizedTangentLinearMap_surjective + {K : Type*} [Field K] {n : ℕ} + (q : Fin (n + 1) → K) (hq0 : q 0 ≠ 0) : + Function.Surjective (dehomogenizedTangentLinearMap q) := by + intro v + refine ⟨Fin.cases 0 (fun i => v i * q 0), ?_⟩ + ext i + change (v i * q 0 * q 0 - q i.succ * 0) / q 0 ^ 2 = v i + field_simp + ring + +/-- If the scalar-extended lattice is the projective tangent cone, any matrix +whose columns span that lattice contains the projective point and its chart +derivatives span exactly the affine tangent space. This is the dictionary +formerly exposed as the separate `hposition` and `htangent` inputs. -/ +private theorem matrix_tangent_dictionary + {K : Type*} [Field K] {n : ℕ} {κ : Type*} [Fintype κ] + (q : Fin (n + 1) → K) (hq0 : q 0 ≠ 0) + (T : Submodule K (Fin n → K)) + (B : Matrix (Fin (n + 1)) κ K) + (hspan : Submodule.span K + (Set.range fun j => fun i => B i j) = projectiveTangentCone q T) : + (∃ c : κ → K, ∀ i, q i = ∑ j, B i j * c j) ∧ + dehomogenizedTangentSpan q B = T := by + have hqcone : q ∈ projectiveTangentCone q T := by + change dehomogenizedTangentColumn q q ∈ T + convert T.zero_mem using 1 + ext i + simp [dehomogenizedTangentColumn] + have hqspan : q ∈ Submodule.span K + (Set.range fun j => fun i => B i j) := by + rw [hspan] + exact hqcone + obtain ⟨c, hc⟩ := + (Submodule.mem_span_range_iff_exists_fun K).mp hqspan + refine ⟨⟨c, fun i => ?_⟩, ?_⟩ + · have hi := congrFun hc.symm i + simpa [Finset.sum_apply, smul_eq_mul, mul_comm] using hi + let d := dehomogenizedTangentLinearMap q + calc + dehomogenizedTangentSpan q B = + (Submodule.span K (Set.range fun j => fun i => B i j)).map d := by + rw [dehomogenizedTangentSpan, Submodule.map_span] + congr 1 + ext v + simp only [Set.mem_image, Set.mem_range] + constructor + · rintro ⟨j, rfl⟩ + exact ⟨fun i => B i j, ⟨j, rfl⟩, rfl⟩ + · rintro ⟨_, ⟨j, rfl⟩, rfl⟩ + exact ⟨j, rfl⟩ + _ = (projectiveTangentCone q T).map d := by rw [hspan] + _ = T := by + exact Submodule.map_comap_eq_of_surjective + (dehomogenizedTangentLinearMap_surjective q hq0) T + +/-- The data appearing in the paper's tangent-limit hypothesis, expressed in +the affine chart of the projective arc. `hposition` says that the generic +projective point belongs to the cone spanned by the generic tangent lattice; +the tangent-space equality is the exact smooth affine tangent dictionary. +The cardinality equation records the advertised rank `dimY + 1`. +-/ +structure Input {n dimY : ℕ} {κ : Type*} [Fintype κ] [DecidableEq κ] + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (B : Matrix (Fin (n + 1)) κ (PowerSeries k)) where + axis : Fin n + C : Matrix κ (Fin (n + 1)) (PowerSeries k) + hprime : I.IsPrime + hsplit : C * B = 1 + hrank : Fintype.card κ = dimY + 1 + hq0 : q 0 ≠ 0 + hbase : ∀ f ∈ I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0 + hsmooth : SmoothAffinePoint + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (dehomogenizedPoint (laurentColumn q)) + hposition : ∃ c : κ → LaurentSeries k, ∀ i, + laurentColumn q i = ∑ j, algebraMap (PowerSeries k) (LaurentSeries k) + (B i j) * c j + htangent : dehomogenizedTangentSpan (laurentColumn q) + (fun i j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) = + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + haxis : ∀ j, PowerSeries.constantCoeff (B axis.succ j) = 0 + +/-- The hypotheses of the paper's tangent-limit lemma, with the tangent +lattice supplied as an actual direct summand rather than chosen matrices. +`hgenericTangentCone` is literally the assertion that its Laurent generic +fibre is the affine cone over the embedded projective tangent plane, using +`projectiveTangentCone` above. -/ +structure DirectSummandInput {n dimY : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (L : Submodule (PowerSeries k) + (Fin (n + 1) → PowerSeries k)) where + axis : Fin n + isComplemented : IsComplemented L + rank_eq : Module.finrank (PowerSeries k) L = dimY + 1 + hprime : I.IsPrime + chart_nonzero : q 0 ≠ 0 + arc_mem_closure : FormalProjectiveArcInClosure I q + generic_smooth : SmoothAffinePoint + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (dehomogenizedPoint (laurentColumn q)) + hgenericTangentCone : + genericFibre (K := LaurentSeries k) L = + projectiveTangentCone (laurentColumn q) + (zariskiTangentSpace + (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) + residue_le_coordinateHyperplane : ∀ v : L, + PowerSeries.constantCoeff ((v : Fin (n + 1) → PowerSeries k) axis.succ) = 0 + +private theorem rowMul_zero_of_leftInverse_axis + {n : ℕ} {κ : Type*} [Fintype κ] [DecidableEq κ] + (B : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (C : Matrix κ (Fin (n + 1)) (PowerSeries k)) + (axis : Fin (n + 1)) + (hCB : C * B = 1) + (haxis : ∀ j, PowerSeries.constantCoeff (B axis j) = 0) : + ∃ ell : Fin (n + 1) → PowerSeries k, + rowMul ell B = 0 ∧ + residueColumn ell = axisRow (k := k) axis := by + let a₀ : Fin (n + 1) → k := axisRow (k := k) axis + let a : Fin (n + 1) → PowerSeries k := constantColumn a₀ + have hres : residueColumn a = a₀ := by + exact residueColumn_constantColumn a₀ + have hred : rowMul a₀ + (fun i j ↦ PowerSeries.constantCoeff (B i j)) = 0 := by + funext j + simp [a₀, axisRow, rowMul, haxis j] + let ell : Fin (n + 1) → PowerSeries k := annihilatorLift a B C + have hell := powerSeries_annihilatorLift_spec a a₀ B C hCB hres hred + refine ⟨ell, ?_, ?_⟩ + · exact hell.1 + · simpa [ell, a₀] using hell.2 + +private theorem rowMul_laurent_of_rowMul + {n : ℕ} {κ : Type*} [Fintype κ] + (ell : Fin (n + 1) → PowerSeries k) + (B : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (h : rowMul ell B = 0) : + rowMul (laurentColumn ell) + (fun i j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) = 0 := by + funext j + have hj := congrFun h j + simpa [rowMul, laurentColumn, map_sum] using + congrArg (algebraMap (PowerSeries k) (LaurentSeries k)) hj + +theorem exists_axis_laurent_smooth_conormal_direction + {n dimY : ℕ} {κ : Type*} [Fintype κ] [DecidableEq κ] + [IsAlgClosed k] + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (B : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (D : Input (dimY := dimY) I q B) : + ∃ ell : Fin (n + 1) → PowerSeries k, + rowMul ell B = 0 ∧ + residueColumn ell = axisRow (k := k) D.axis.succ ∧ + (let phase : PhaseVar n → LaurentSeries k := + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (ell i.succ)); + phase ∈ smoothEquationConormalLocus I ∧ + residueColumn (fun i : Fin n ↦ ell i.succ) ∈ + extensionFibreClosure (k := k) (K := LaurentSeries k) + (smoothEquationConormalLocus I) ∧ + Projectivization.mk k + (fun i : Fin n => if i = D.axis then (1 : k) else 0) + (by intro h; have hh := congrFun h D.axis; simpa using hh) ∈ + projectiveHomogeneousClosure + (projectivizedDirectionSet (smoothConormalDirectionSet I))) := by + obtain ⟨ell, hrow, hres⟩ := rowMul_zero_of_leftInverse_axis + B D.C D.axis.succ D.hsplit D.haxis + have hrowL := rowMul_laurent_of_rowMul ell B hrow + have hqL : ∑ i, laurentColumn ell i * laurentColumn q i = 0 := by + obtain ⟨c, hc⟩ := D.hposition + have hprod : ∑ i, laurentColumn ell i * laurentColumn q i = + ∑ j, (∑ i, laurentColumn ell i * + algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) * c j := by + calc + ∑ i, laurentColumn ell i * laurentColumn q i = + ∑ i, laurentColumn ell i * + (∑ j, algebraMap (PowerSeries k) (LaurentSeries k) + (B i j) * c j) := by + apply Finset.sum_congr rfl + intro i hi + rw [hc i] + _ = ∑ i, ∑ j, laurentColumn ell i * + (algebraMap (PowerSeries k) (LaurentSeries k) (B i j) * c j) := by + apply Finset.sum_congr rfl + intro i hi + rw [Finset.mul_sum] + _ = ∑ j, ∑ i, laurentColumn ell i * + (algebraMap (PowerSeries k) (LaurentSeries k) (B i j) * c j) := + Finset.sum_comm + _ = ∑ j, (∑ i, laurentColumn ell i * + algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) * c j := by + apply Finset.sum_congr rfl + intro j hj + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro i hi + ring + rw [hprod] + have hzero : ∀ j, (∑ i, laurentColumn ell i * + algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) = 0 := by + intro j + exact congrFun hrowL j + change (∑ j, rowMul (laurentColumn ell) + (fun i l ↦ algebraMap (PowerSeries k) (LaurentSeries k) (B i l)) j * c j) = 0 + rw [hrowL] + simp + have hphase : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (ell i.succ)) ∈ + equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) := by + exact phasePoint_mem_equationConormalLocus_of_projective_row + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (laurentColumn q) (laurentColumn ell) + (fun i j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (B i j)) + (laurentColumn_ne_zero_of_ne_zero q D.hq0) + hqL hrowL D.hbase D.htangent + let phase : PhaseVar n → LaurentSeries k := + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (ell i.succ)) + have hphaseSmooth : phase ∈ smoothEquationConormalLocus I := by + exact ⟨hphase, D.hsmooth⟩ + have hclosure := residue_mem_extensionFibreClosure_of_laurent_generic + (S := smoothEquationConormalLocus I) + (dehomogenizedPoint (laurentColumn q)) + (fun i : Fin n ↦ ell i.succ) hphaseSmooth + let axisVec : Fin n → k := fun i => if i = D.axis then 1 else 0 + have hresTail : residueColumn (fun i : Fin n ↦ ell i.succ) = axisVec := by + funext i + have hi := congrFun hres i.succ + simpa [residueColumn, axisRow, axisVec] using hi + have hvanAxis : axisVec ∈ + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (smoothConormalFibreProjection I)) := by + rw [MvPolynomial.mem_zeroLocus_iff] + intro P hP + have hf : fibreLift P ∈ + MvPolynomial.vanishingIdeal k (equationConormalLocus I) := + fibreLift_mem_vanishingIdeal_equationConormal I D.hprime P hP + have hPext : P ∈ extensionValuedVanishingIdeal + (k := k) (K := LaurentSeries k) + (fibreImage (smoothEquationConormalLocus I)) := by + rw [mem_extensionValuedVanishingIdeal_iff] + intro v hv + rcases hv with ⟨z, hz, rfl⟩ + have hs := scalarExtension_vanishing I (fibreLift P) (by + simpa [fibreLift, MvPolynomial.eval_rename, Function.comp_def] using hf) + z hz.1 + have hsplit : + Sum.elim (fun i ↦ z (Sum.inl i)) (fun i ↦ z (Sum.inr i)) = z := by + funext i + rcases i with i | i <;> rfl + rw [← hsplit] at hs + simpa [eval₂_fibreLift] using hs + have hz := hclosure P hPext + rw [hresTail] at hz + simpa [MvPolynomial.aeval_eq_eval] using hz + have hproj := mk_mem_projectiveHomogeneousClosure_of_fibre_zeroLocus + I axisVec (by + intro h + have hh := congrFun h D.axis + simpa [axisVec] using hh) hvanAxis + exact ⟨ell, hrow, hres, ⟨hphaseSmooth, hclosure, by simpa [axisVec] using hproj⟩⟩ + +/-- Paper-level tangent-limit criterion. Starting from an actual rank +`dimY + 1` direct-summand lattice whose generic fibre is the projective +tangent cone, this theorem constructs split matrix coordinates internally and +applies `exists_axis_laurent_smooth_conormal_direction`. No annihilator, +matrix retraction, position coefficients, or chart tangent dictionary occurs +in the input. -/ +theorem tangent_limit_criterion_of_directSummand + {n dimY : ℕ} [IsAlgClosed k] + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (L : Submodule (PowerSeries k) + (Fin (n + 1) → PowerSeries k)) + (D : DirectSummandInput (dimY := dimY) I q L) : + Projectivization.mk k + (fun i : Fin n => if i = D.axis then (1 : k) else 0) + (by intro h; have hh := congrFun h D.axis; simpa using hh) ∈ + projectiveHomogeneousClosure + (projectivizedDirectionSet (smoothConormalDirectionSet I)) := by + obtain ⟨P⟩ := exists_splitMatrixPresentation_of_isComplemented + L D.isComplemented (dimY + 1) D.rank_eq + let B : Matrix (Fin (n + 1)) (Fin (dimY + 1)) + (PowerSeries k) := P.B + let BL : Matrix (Fin (n + 1)) (Fin (dimY + 1)) + (LaurentSeries k) := + fun i j => algebraMap (PowerSeries k) (LaurentSeries k) (B i j) + have hgenericSpan : + Submodule.span (LaurentSeries k) + (Set.range fun j => fun i => BL i j) = + projectiveTangentCone (laurentColumn q) + (zariskiTangentSpace + (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) := by + rw [← D.hgenericTangentCone, + genericFibre_eq_span_matrixColumns L B P.columnsSpan] + have hq0L : laurentColumn q 0 ≠ 0 := + laurentColumn_ne_zero_of_ne_zero q D.chart_nonzero + obtain ⟨hposition, htangent⟩ := matrix_tangent_dictionary + (laurentColumn q) hq0L + (zariskiTangentSpace + (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) + BL hgenericSpan + have hbase : ∀ f ∈ I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0 := by + have hz := (projectiveClosureAtZero_iff + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + (laurentColumn q) hq0L).mp D.arc_mem_closure.2 + exact hz + have haxis : ∀ j, + PowerSeries.constantCoeff (B D.axis.succ j) = 0 := by + intro j + have hmem : (fun i => B i j) ∈ L := by + rw [← P.columnsSpan] + exact Submodule.subset_span ⟨j, rfl⟩ + let v : L := ⟨fun i => B i j, hmem⟩ + simpa [v] using D.residue_le_coordinateHyperplane v + let low : Input (dimY := dimY) I q B := { + axis := D.axis + C := P.C + hprime := D.hprime + hsplit := P.leftInverse + hrank := by simp + hq0 := D.chart_nonzero + hbase := hbase + hsmooth := D.generic_smooth + hposition := hposition + htangent := htangent + haxis := haxis } + obtain ⟨ell, hrow, hres, hconormal⟩ := + exists_axis_laurent_smooth_conormal_direction I q B low + exact hconormal.2.2 + + +end +end Stafford38.Geometry.GeneralTangentLimitCriterion diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterionTest.lean b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterionTest.lean new file mode 100644 index 0000000000..3f3a15b693 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GeneralTangentLimitCriterionTest.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.GeneralTangentLimitCriterion + +/-! +# Independent consumer for the paper-level tangent-limit criterion + +This consumer keeps the manuscript's quantifier order visible. It starts +with an arbitrary prime affine variety, a formal projective arc in its +homogeneous-equation closure, and an actual finite-rank direct-summand tangent +lattice. No matrix basis, retraction, annihilator, position coefficients, or +separate tangent-chart equality is supplied. +-/ + +namespace Stafford38.Geometry.GeneralTangentLimitCriterionTest + +open Stafford38.Geometry.GeneralTangentLimitCriterion +open Stafford38.Geometry.ProjectiveConormalDirections + +noncomputable section + +variable {k : Type*} [Field k] [IsAlgClosed k] + +theorem paper_shape_consumer + {n dimY : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) + (q : Fin (n + 1) → PowerSeries k) + (L : Submodule (PowerSeries k) + (Fin (n + 1) → PowerSeries k)) + (D : DirectSummandInput (dimY := dimY) I q L) : + Projectivization.mk k + (fun i : Fin n => if i = D.axis then (1 : k) else 0) + (by intro h; have hh := congrFun h D.axis; simpa using hh) ∈ + projectiveHomogeneousClosure + (projectivizedDirectionSet (smoothConormalDirectionSet I)) := by + exact tangent_limit_criterion_of_directSummand I q L D + + +end +end Stafford38.Geometry.GeneralTangentLimitCriterionTest diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GenericPointKaehlerConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/GenericPointKaehlerConormal.lean new file mode 100644 index 0000000000..b6b7bf5c29 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GenericPointKaehlerConormal.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.MvPolynomial.Derivation +import Mathlib.Algebra.MvPolynomial.PDeriv +import Mathlib.RingTheory.Etale.Kaehler +import Mathlib.RingTheory.Localization.FractionRing +import Mathlib.RingTheory.Localization.Module +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalSpan + +/-! +# Kähler relations at the generic point are affine conormal covectors + +Let `A = k[X_1, …, X_m] ⧸ I` be a prime affine component with fraction +field `F`, and let `y_i ∈ F` be the images of the coordinates (the generic +point of the component). If a coefficient vector `ξ ∈ F^m` satisfies the +Kähler relation `∑ ξ_i d y_i = 0` in `Ω[F⁄k]`, then the coordinate covector +`v ↦ ∑ ξ_i v_i` lies in the equation-defined affine conormal space of the +extended ideal `I·F[X]` at `y`. + +The proof turns a tangent vector `v` into a derivation `k[X] → F`, descends +it to `A`, extends it through `Ω[A⁄k] → Ω[F⁄k]` (which is a localization of +modules), and evaluates the resulting `F`-linear functional on the relation. + +Not proved here: nothing about places, residue fields, boundary charts, +smoothness, or geometric conormal bundles. Only linear algebra of Kähler +differentials and derivations over the fraction field of a quotient ring. +-/ + +namespace Stafford38.Geometry.GenericPointKaehlerConormal + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open MvPolynomial + +noncomputable section + +universe u + + +variable {k : Type u} [Field k] {m : ℕ} + +section Descent + +variable {P : Type*} [CommRing P] [Algebra k P] {I : Ideal P} + {F : Type*} [CommRing F] [Algebra k F] [Algebra (P ⧸ I) F] + [IsScalarTower k (P ⧸ I) F] [Module P F] + +/-- The underlying linear map of a derivation vanishing on `I`, descended to +the quotient `P ⧸ I`. -/ +def quotientDerivationLinear (D : Derivation k P F) (hD : ∀ f ∈ I, D f = 0) : + (P ⧸ I) →ₗ[k] F := + (Submodule.liftQ (I.restrictScalars k) D.toLinearMap (by + intro f hf + exact hD f hf)).comp + (Submodule.Quotient.restrictScalarsEquiv k I).symm.toLinearMap + +theorem quotientDerivationLinear_mk (D : Derivation k P F) (hD : ∀ f ∈ I, D f = 0) + (f : P) : + quotientDerivationLinear D hD (Ideal.Quotient.mk I f) = D f := + rfl + +/-- A derivation `P → F` vanishing on `I` descends to a derivation `P ⧸ I → F`, +provided the `P`-action on `F` factors through `P ⧸ I`. -/ +def quotientDerivation [IsScalarTower P (P ⧸ I) F] + (D : Derivation k P F) (hD : ∀ f ∈ I, D f = 0) : + Derivation k (P ⧸ I) F where + toLinearMap := quotientDerivationLinear D hD + map_one_eq_zero' := by + have h1 : (1 : P ⧸ I) = Ideal.Quotient.mk I 1 := by simp + rw [h1] + change quotientDerivationLinear D hD (Ideal.Quotient.mk I 1) = 0 + rw [quotientDerivationLinear_mk, Derivation.map_one_eq_zero] + leibniz' a b := by + obtain ⟨p, rfl⟩ := Ideal.Quotient.mk_surjective a + obtain ⟨q, rfl⟩ := Ideal.Quotient.mk_surjective b + change quotientDerivationLinear D hD (Ideal.Quotient.mk I p * Ideal.Quotient.mk I q) = + Ideal.Quotient.mk I p • quotientDerivationLinear D hD (Ideal.Quotient.mk I q) + + Ideal.Quotient.mk I q • quotientDerivationLinear D hD (Ideal.Quotient.mk I p) + rw [← map_mul, quotientDerivationLinear_mk, quotientDerivationLinear_mk, + quotientDerivationLinear_mk, Derivation.leibniz] + rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_smul (P ⧸ I) p, + ← IsScalarTower.algebraMap_smul (P ⧸ I) q] + +theorem quotientDerivation_mk [IsScalarTower P (P ⧸ I) F] + (D : Derivation k P F) (hD : ∀ f ∈ I, D f = 0) (f : P) : + quotientDerivation D hD (Ideal.Quotient.mk I f) = D f := + quotientDerivationLinear_mk D hD f + +end Descent + +section Main + +variable {F : Type*} [Field F] [Algebra k F] + {I : Ideal (MvPolynomial (Fin m) k)} [I.IsPrime] + [Algebra (MvPolynomial (Fin m) k ⧸ I) F] + [IsScalarTower k (MvPolynomial (Fin m) k ⧸ I) F] + [IsFractionRing (MvPolynomial (Fin m) k ⧸ I) F] + +/-- The generic point of the component: images of the coordinates in `F`. -/ +def genericPoint (I : Ideal (MvPolynomial (Fin m) k)) (F : Type*) [Field F] + [Algebra (MvPolynomial (Fin m) k ⧸ I) F] : Fin m → F := + fun i ↦ algebraMap (MvPolynomial (Fin m) k ⧸ I) F (Ideal.Quotient.mk I (X i)) + +/-- The equation ideal extended to `F[X]`. -/ +def extendedIdeal (I : Ideal (MvPolynomial (Fin m) k)) (F : Type*) [Field F] + [Algebra k F] : Ideal (MvPolynomial (Fin m) F) := + I.map (MvPolynomial.map (algebraMap k F)) + +/-- Evaluation of `MvPolynomial.mkDerivation` through partial derivatives, +when the polynomial ring acts on `F` through evaluation at `y`. -/ +theorem mkDerivation_eq_sum_pderiv [Algebra (MvPolynomial (Fin m) k) F] + [IsScalarTower k (MvPolynomial (Fin m) k) F] + (y v : Fin m → F) + (halg : ∀ p : MvPolynomial (Fin m) k, algebraMap (MvPolynomial (Fin m) k) F p = aeval y p) + (f : MvPolynomial (Fin m) k) : + mkDerivation k v f = ∑ i, aeval y (pderiv i f) * v i := by + classical + induction f using MvPolynomial.induction_on with + | C a => + rw [← MvPolynomial.algebraMap_eq, Derivation.map_algebraMap] + simp + | add p q hp hq => + simp only [map_add, hp, hq, add_mul, Finset.sum_add_distrib] + | mul_X p n hp => + have h1 : ∑ i, aeval y (pderiv i (p * X n)) * v i = + aeval y p * v n + y n * ∑ i, aeval y (pderiv i p) * v i := by + have h2 : ∀ i, aeval y (pderiv i (p * X n)) * v i = + aeval y p * (if n = i then v i else 0) + y n * (aeval y (pderiv i p) * v i) := by + intro i + simp only [pderiv_mul, map_add, map_mul, aeval_X, pderiv_X, Pi.single_apply] + split_ifs <;> simp <;> ring + simp only [h2, Finset.sum_add_distrib, ← Finset.mul_sum, Finset.sum_ite_eq, + Finset.mem_univ, if_true] + rw [h1, Derivation.leibniz, mkDerivation_X, hp, Algebra.smul_def, Algebra.smul_def, halg, halg, + aeval_X] + +/-- Nonzero-divisors of `A` act invertibly on the fraction field `F`. -/ +theorem isUnit_algebraMap_end + (s : nonZeroDivisors (MvPolynomial (Fin m) k ⧸ I)) : + IsUnit (algebraMap (MvPolynomial (Fin m) k ⧸ I) + (Module.End (MvPolynomial (Fin m) k ⧸ I) F) s) := by + rw [Module.End.isUnit_iff] + have hfun : ⇑(algebraMap (MvPolynomial (Fin m) k ⧸ I) + (Module.End (MvPolynomial (Fin m) k ⧸ I) F) s) = fun x ↦ (s : MvPolynomial (Fin m) k ⧸ I) • x := + funext fun _ ↦ rfl + rw [hfun] + have := IsLocalization.smul_bijective (M := nonZeroDivisors (MvPolynomial (Fin m) k ⧸ I)) F s + simpa [Submonoid.smul_def] using this + +/-- **Main theorem.** A Kähler relation among the generic-point coordinates +places the corresponding coordinate covector in the affine conormal space of +the extended ideal at the generic point. -/ +theorem coordinateCovector_mem_affineConormalSpace_of_kaehler_sum_eq_zero + (xi : Fin m → F) + (h : ∑ i, xi i • KaehlerDifferential.D k F (genericPoint I F i) = 0) : + coordinateCovector xi ∈ affineConormalSpace (genericPoint I F) (extendedIdeal I F) := by + classical + set A := MvPolynomial (Fin m) k ⧸ I + set y := genericPoint I F + rw [affineConormalSpace, Submodule.mem_dualAnnihilator] + intro v hv + rw [zariskiTangentSpace, Submodule.mem_dualCoannihilator] at hv + have htan : ∀ f ∈ extendedIdeal I F, ∑ i, differentialAt y f i * v i = 0 := by + intro f hf + have := hv (differentialCovector y f) (Submodule.subset_span ⟨⟨f, hf⟩, rfl⟩) + simpa using this + -- `P`-algebra structure on `F` through the quotient and the fraction field. + let _ : Algebra (MvPolynomial (Fin m) k) F := + ((algebraMap A F).comp (algebraMap (MvPolynomial (Fin m) k) A)).toAlgebra + have : IsScalarTower (MvPolynomial (Fin m) k) A F := by + refine ⟨fun p a x ↦ ?_⟩ + obtain ⟨q, rfl⟩ := Ideal.Quotient.mk_surjective a + rw [← Ideal.Quotient.mk_eq_mk, ← Submodule.Quotient.mk_smul, Ideal.Quotient.mk_eq_mk, + smul_eq_mul, Algebra.smul_def, Algebra.smul_def, Algebra.smul_def, map_mul, map_mul, + mul_assoc] + rfl + have : IsScalarTower k (MvPolynomial (Fin m) k) F := + IsScalarTower.of_algebraMap_eq fun a ↦ by + change algebraMap k F a = algebraMap A F (algebraMap (MvPolynomial (Fin m) k) A (algebraMap k _ a)) + rw [← IsScalarTower.algebraMap_apply k (MvPolynomial (Fin m) k) A, + ← IsScalarTower.algebraMap_apply k A F] + have halg : ∀ p : MvPolynomial (Fin m) k, algebraMap (MvPolynomial (Fin m) k) F p = aeval y p := by + intro p + have : (IsScalarTower.toAlgHom k (MvPolynomial (Fin m) k) F) = aeval y := by + apply MvPolynomial.algHom_ext + intro i + rw [IsScalarTower.coe_toAlgHom', aeval_X] + rfl + exact (AlgHom.congr_fun this p) + -- The tangent vector as a derivation `P → F`. + let DP : Derivation k (MvPolynomial (Fin m) k) F := mkDerivation k v + have hDP : ∀ f, DP f = ∑ i, aeval y (pderiv i f) * v i := + mkDerivation_eq_sum_pderiv y v halg + have hDPI : ∀ f ∈ I, DP f = 0 := by + intro f hf + rw [hDP] + have hmem : MvPolynomial.map (algebraMap k F) f ∈ extendedIdeal I F := + Ideal.mem_map_of_mem _ hf + have := htan _ hmem + convert this using 2 with i + rw [differentialAt, pderiv_map, eval_map, aeval_def] + -- Descend to `A`. + let DA : Derivation k A F := quotientDerivation DP hDPI + have hDA : ∀ i, DA (Ideal.Quotient.mk I (X i)) = v i := by + intro i + rw [quotientDerivation_mk] + exact mkDerivation_X k v i + -- Lift through Kähler differentials of `A`. + let ψ : Ω[A⁄k] →ₗ[A] F := DA.liftKaehlerDifferential + -- Extend through the localization `Ω[A⁄k] → Ω[F⁄k]`. + let φ : Ω[F⁄k] →ₗ[A] F := + IsLocalizedModule.lift (nonZeroDivisors A) (KaehlerDifferential.map k k A F) ψ + isUnit_algebraMap_end + have hφ : ∀ i, φ (KaehlerDifferential.D k F (y i)) = v i := by + intro i + have hyi : y i = algebraMap A F (Ideal.Quotient.mk I (X i)) := rfl + rw [hyi, ← KaehlerDifferential.map_D k k A F, IsLocalizedModule.lift_apply] + change DA.liftKaehlerDifferential (KaehlerDifferential.D k A _) = _ + rw [Derivation.liftKaehlerDifferential_comp_D, hDA] + let Φ : Ω[F⁄k] →ₗ[F] F := LinearMap.extendScalarsOfIsLocalization (nonZeroDivisors A) F φ + have hΦ := congrArg Φ h + rw [map_sum, map_zero] at hΦ + simp only [map_smul, LinearMap.extendScalarsOfIsLocalization_apply', Φ, hφ, smul_eq_mul] at hΦ + simpa using hΦ + +end Main + +end + +end Stafford38.Geometry.GenericPointKaehlerConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/GenericSmoothOpen.lean b/LeanPool/Stafford38/Stafford38/Geometry/GenericSmoothOpen.lean new file mode 100644 index 0000000000..ae5202880e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/GenericSmoothOpen.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Smooth.Field +import Mathlib.RingTheory.Smooth.Locus +import Mathlib.RingTheory.FinitePresentation + +/-! +# A generic smooth principal open + +For a finite-type domain over a perfect field, the generic localization is a +finitely generated field extension and hence formally smooth. Mathlib's +smooth-locus spreading theorem then supplies a nonzero principal open which +is smooth. This file deliberately makes no Jacobian or conormal +identification. +-/ + +namespace Stafford38.Geometry + +noncomputable section + +variable {k A : Type*} {n : ℕ} [Field k] [PerfectField k] [CommRing A] + [IsDomain A] [Algebra k A] [Algebra.FiniteType k A] + [Algebra.FinitePresentation k A] + +theorem exists_nonzero_smooth_away + : ∃ f : A, f ≠ 0 ∧ Algebra.Smooth k (Localization.Away f) := by + letI : Algebra.IsSmoothAt k (⊥ : Ideal A) := by + change Algebra.FormallySmooth k (Localization.AtPrime (⊥ : Ideal A)) + letI : Field (Localization.AtPrime (⊥ : Ideal A)) := + IsField.toField (by + rw [IsLocalRing.isField_iff_maximalIdeal_eq] + rw [← Localization.AtPrime.map_eq_maximalIdeal] + simp) + exact Algebra.FormallySmooth.of_perfectField + (K := k) (L := Localization.AtPrime (⊥ : Ideal A)) + obtain ⟨f, hf, hsmooth⟩ := + Algebra.IsSmoothAt.exists_notMem_smooth k (⊥ : Ideal A) + exact ⟨f, by simpa using hf, hsmooth⟩ + +theorem exists_nonzero_smooth_away_quotient + (P : Ideal (MvPolynomial (Fin n) k)) [P.IsPrime] : + ∃ f : (MvPolynomial (Fin n) k ⧸ P), f ≠ 0 ∧ + Algebra.Smooth k (Localization.Away f) := by + let A := MvPolynomial (Fin n) k ⧸ P + letI : Algebra k A := Ideal.Quotient.algebra k + letI : Algebra.FinitePresentation k A := by + dsimp [A] + exact Algebra.FinitePresentation.quotient P.fg_of_isNoetherianRing + simpa [A] using (exists_nonzero_smooth_away (k := k) (A := A)) + + +end +end Stafford38.Geometry diff --git a/LeanPool/Stafford38/Stafford38/Geometry/JacobianConormalComparison.lean b/LeanPool/Stafford38/Stafford38/Geometry/JacobianConormalComparison.lean new file mode 100644 index 0000000000..4b09892cfc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/JacobianConormalComparison.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure + +/-! +# Comparing Jacobian and equation-defined affine conormals + +An externally supplied smooth locus can be compared with the repository's +equation-defined conormal locus once its tangent space is identified with the +common kernel of a family of Jacobian rows. This file isolates that exact +bridge. + +The equations in the Jacobian family are required to belong to the ambient +ideal. Under that hypothesis, their conormal space is contained in the +conormal space defined using all equations. Consequently, if the supplied +tangent space agrees pointwise with the Jacobian kernel, its conormal locus +embeds into `equationConormalLocus`, and its field-valued algebraic closure +hull embeds into `equationConormalClosure`. + +No smoothness criterion, scheme tangent-space construction, geometric-point +comparison, algebraic closedness, or base change is asserted here. Those are +inputs to the comparison theorem, not consequences of it. +-/ + +namespace Stafford38.Geometry.JacobianConormalComparison + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- The span of the Jacobian rows of a chosen family of equations at `y`. -/ +def jacobianCovectorSpan {ι : Type*} (y : Fin n → k) + (equations : ι → MvPolynomial (Fin n) k) : + Submodule k (Module.Dual k (AffineTangentVector k n)) := + Submodule.span k (Set.range fun i ↦ differentialCovector y (equations i)) + +/-- The tangent space cut out by the chosen Jacobian rows. -/ +def jacobianTangentSpace {ι : Type*} (y : Fin n → k) + (equations : ι → MvPolynomial (Fin n) k) : + Submodule k (AffineTangentVector k n) := + (jacobianCovectorSpan y equations).dualCoannihilator + +/-- The conormal space obtained as the annihilator of the Jacobian kernel. -/ +def jacobianConormalSpace {ι : Type*} (y : Fin n → k) + (equations : ι → MvPolynomial (Fin n) k) : + Submodule k (Module.Dual k (AffineTangentVector k n)) := + (jacobianTangentSpace y equations).dualAnnihilator + +/-- In finite-dimensional affine space, taking the annihilator of the +Jacobian kernel recovers the span of the Jacobian rows. -/ +theorem jacobianConormalSpace_eq_jacobianCovectorSpan {ι : Type*} + (y : Fin n → k) (equations : ι → MvPolynomial (Fin n) k) : + jacobianConormalSpace y equations = jacobianCovectorSpan y equations := by + classical + exact Subspace.dualCoannihilator_dualAnnihilator_eq + +/-- Jacobian rows coming from equations in `I` span a subspace of the +covectors generated by all equations in `I`. -/ +theorem jacobianCovectorSpan_le_equationCovectorSpan {ι : Type*} + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) : + jacobianCovectorSpan y equations ≤ equationCovectorSpan y I := by + apply Submodule.span_le.mpr + rintro _ ⟨i, rfl⟩ + apply Submodule.subset_span + exact ⟨⟨equations i, hequations i⟩, rfl⟩ + +/-- The conormal computed from any chosen equations in `I` embeds in the +equation-defined affine conormal computed from the whole ideal. -/ +theorem jacobianConormalSpace_le_affineConormalSpace {ι : Type*} + (y : Fin n → k) (I : Ideal (MvPolynomial (Fin n) k)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) : + jacobianConormalSpace y equations ≤ affineConormalSpace y I := by + rw [jacobianConormalSpace_eq_jacobianCovectorSpan, + affineConormalSpace_eq_equationCovectorSpan] + exact jacobianCovectorSpan_le_equationCovectorSpan y I equations hequations + +/-- The conormal locus of a supplied set of base points and supplied tangent +spaces. For a smooth locally closed locus, callers instantiate `Y` with its +field-valued points and `T` with its scheme-theoretic tangent spaces. -/ +def tangentConormalLocus + (Y : Set (Fin n → k)) + (T : (Fin n → k) → Submodule k (AffineTangentVector k n)) : + Set (PhaseVar n → k) := + {q | (fun i ↦ q (Sum.inl i)) ∈ Y ∧ + coordinateCovector (fun i ↦ q (Sum.inr i)) ∈ + (T (fun i ↦ q (Sum.inl i))).dualAnnihilator} + +/-- Exact pointwise smooth-conormal comparison. + +The caller supplies two geometric facts: points of `Y` satisfy `I`, and the +supplied tangent space on `Y` is the kernel of the displayed Jacobian rows. +The latter is the explicit Jacobian/tangent hypothesis normally furnished by +smoothness. -/ +theorem tangentConormalLocus_subset_equationConormalLocus_of_eq_jacobian + {ι : Type*} + (I : Ideal (MvPolynomial (Fin n) k)) + (Y : Set (Fin n → k)) + (T : (Fin n → k) → Submodule k (AffineTangentVector k n)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) + (hY : ∀ y ∈ Y, ∀ f ∈ I, MvPolynomial.eval y f = 0) + (hT : ∀ y ∈ Y, T y = jacobianTangentSpace y equations) : + tangentConormalLocus Y T ⊆ equationConormalLocus I := by + intro q hq + let y : Fin n → k := fun i ↦ q (Sum.inl i) + let ξ : Fin n → k := fun i ↦ q (Sum.inr i) + refine ⟨hY y hq.1, ?_⟩ + apply jacobianConormalSpace_le_affineConormalSpace y I equations hequations + change coordinateCovector ξ ∈ jacobianConormalSpace y equations + have hq' := hq.2 + change coordinateCovector ξ ∈ (T y).dualAnnihilator at hq' + rw [hT y hq.1] at hq' + exact hq' + +/-- Closure-level form of the comparison: the field-valued algebraic closure +hull of the supplied tangent conormal locus lies in the equation-defined +conormal closure. -/ +theorem tangentConormalClosure_subset_equationConormalClosure_of_eq_jacobian + {ι : Type*} + (I : Ideal (MvPolynomial (Fin n) k)) + (Y : Set (Fin n → k)) + (T : (Fin n → k) → Submodule k (AffineTangentVector k n)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ I) + (hY : ∀ y ∈ Y, ∀ f ∈ I, MvPolynomial.eval y f = 0) + (hT : ∀ y ∈ Y, T y = jacobianTangentSpace y equations) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (tangentConormalLocus Y T)) ⊆ + equationConormalClosure I := by + rw [equationConormalClosure] + exact MvPolynomial.zeroLocus_anti_mono + (MvPolynomial.vanishingIdeal_anti_mono + (tangentConormalLocus_subset_equationConormalLocus_of_eq_jacobian + I Y T equations hequations hY hT)) + +/-- Direct characteristic-support consumer. Once the tangent data on `Y` +are identified with Jacobian kernels for equations in the contracted base +ideal, the closure of their conormal locus lies in reduced order support under +the existing base-relative Gabber fragment. -/ +theorem tangentConormalClosure_subset_reducedOrderSupport_of_eq_jacobian + [CharZero k] + {ι : Type*} + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k W)) + (Y : Set (Fin n → k)) + (T : (Fin n → k) → Submodule k (AffineTangentVector k n)) + (equations : ι → MvPolynomial (Fin n) k) + (hequations : ∀ i, equations i ∈ reducedOrderBaseIdeal k W) + (hY : ∀ y ∈ Y, ∀ f ∈ reducedOrderBaseIdeal k W, + MvPolynomial.eval y f = 0) + (hT : ∀ y ∈ Y, T y = jacobianTangentSpace y equations) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (tangentConormalLocus Y T)) ⊆ + MvPolynomial.zeroLocus k (reducedOrderSupportIdeal k W) := by + exact (tangentConormalClosure_subset_equationConormalClosure_of_eq_jacobian + (reducedOrderBaseIdeal k W) Y T equations hequations hY hT).trans + (equationConormalClosure_subset_reducedOrderSupport W hJ) + + +end + +end Stafford38.Geometry.JacobianConormalComparison diff --git a/LeanPool/Stafford38/Stafford38/Geometry/KaehlerDVRVisibility.lean b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerDVRVisibility.lean new file mode 100644 index 0000000000..8a3a9f6104 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerDVRVisibility.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib +import LeanPool.Stafford38.Stafford38.Geometry.DivisorTangentLattice +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerSpanSeparableAdjoin + +/-! +# Kähler visibility at a discrete valuation place + +For a local ring whose maximal ideal is generated by `t`, the kernel of the +map from absolute Kähler differentials to residue-field differentials is the +sum of the line generated by `d t` and the maximal-ideal multiple of the +source module. If the residue field is algebraic over the field generated by +the residues of a coordinate family, those coordinate differentials span the +remaining residue cotangent space. Mapping this statement to the fraction +field gives the visibility condition used by `VisibleDivisorFrame`. +-/ + +namespace Stafford38.Geometry.KaehlerDVRVisibility + +open IsLocalRing +open TensorProduct + +noncomputable section + +universe u v + +/-- Tensoring a module with `V/I` kills exactly the submodule `I • M`. -/ +theorem ker_quotient_tensor_mk_one + {V M : Type*} [CommRing V] + [AddCommGroup M] [Module V M] (I : Ideal V) : + LinearMap.ker (TensorProduct.mk V (V ⧸ I) M 1) = + I • (⊤ : Submodule V M) := by + ext x + constructor + · intro hx + have hzero : TensorProduct.quotTensorEquivQuotSMul M I + ((1 : V ⧸ I) ⊗ₜ[V] x) = 0 := by + change (TensorProduct.quotTensorEquivQuotSMul M I) + ((TensorProduct.mk V (V ⧸ I) M 1) x) = 0 + rw [LinearMap.mem_ker.mp hx, map_zero] + rw [TensorProduct.quotTensorEquivQuotSMul_mk_one_tmul] at hzero + exact (Submodule.Quotient.mk_eq_zero _).mp hzero + · intro hx + apply (TensorProduct.quotTensorEquivQuotSMul M I).injective + change (TensorProduct.quotTensorEquivQuotSMul M I) ((1 : V ⧸ I) ⊗ₜ[V] x) = + (TensorProduct.quotTensorEquivQuotSMul M I) 0 + rw [TensorProduct.quotTensorEquivQuotSMul_mk_one_tmul, + (Submodule.Quotient.mk_eq_zero _).mpr hx, map_zero] + +theorem ker_residue_tensor_mk_one + {V M : Type*} [CommRing V] [IsLocalRing V] + [AddCommGroup M] [Module V M] : + LinearMap.ker (TensorProduct.mk V (ResidueField V) M 1) = + maximalIdeal V • (⊤ : Submodule V M) := by + change LinearMap.ker (TensorProduct.mk V (V ⧸ maximalIdeal V) M 1) = _ + exact ker_quotient_tensor_mk_one (maximalIdeal V) + +/-- If the maximal ideal is generated by `t`, reduction of Kähler +differentials has kernel `V · d t + 𝔪 · Ω[V/k]`. + +The summand generated by `d t` is essential: the kernel is generally larger +than `𝔪 · Ω[V/k]`. -/ +theorem ker_kaehler_residue_map_eq + {k V : Type*} [CommRing k] [CommRing V] [IsLocalRing V] + [Algebra k V] (t : V) (hmax : maximalIdeal V = Ideal.span {t}) : + LinearMap.ker + (KaehlerDifferential.map k k V (ResidueField V)) = + Submodule.span V {KaehlerDifferential.D k V t} ⊔ + maximalIdeal V • (⊤ : Submodule V (Ω[V⁄k])) := by + let f : Ω[V⁄k] →ₗ[V] ResidueField V ⊗[V] Ω[V⁄k] := + TensorProduct.mk V (ResidueField V) Ω[V⁄k] 1 + let g : ResidueField V ⊗[V] Ω[V⁄k] →ₗ[ResidueField V] Ω[ResidueField V⁄k] := + KaehlerDifferential.mapBaseChange k V (ResidueField V) + apply le_antisymm + · intro ω hω + have hgf : g (f ω) = 0 := by + simpa [f, g, KaehlerDifferential.mapBaseChange_tmul] using + (LinearMap.mem_ker.mp hω) + have hfrange : f ω ∈ LinearMap.range + (KaehlerDifferential.kerCotangentToTensor k V (ResidueField V)) := by + rw [KaehlerDifferential.range_kerCotangentToTensor k V (ResidueField V) + IsLocalRing.residue_surjective] + exact hgf + obtain ⟨z, hz⟩ := hfrange + obtain ⟨x, rfl⟩ := Ideal.toCotangent_surjective _ z + have hxmax : (x : V) ∈ maximalIdeal V := by + simpa only [IsLocalRing.ker_residue, ResidueField.algebraMap_eq] using x.property + rw [hmax, Ideal.mem_span_singleton] at hxmax + obtain ⟨a, ha⟩ := hxmax + have hfa : f (a • KaehlerDifferential.D k V t) = + KaehlerDifferential.kerCotangentToTensor k V (ResidueField V) + (Ideal.toCotangent _ x) := by + have htresidue : residue V t = 0 := + (IsLocalRing.residue_eq_zero_iff t).2 + (hmax.symm ▸ Ideal.mem_span_singleton_self t) + rw [KaehlerDifferential.kerCotangentToTensor_toCotangent] + rw [ha, Derivation.leibniz] + simp only [f, map_smul, TensorProduct.tmul_add, + TensorProduct.tmul_smul, TensorProduct.smul_tmul'] + simp [Algebra.smul_def, htresidue] + change (algebraMap V (ResidueField V) a) • + ((1 : ResidueField V) ⊗ₜ[V] KaehlerDifferential.D k V t) = _ + rw [ResidueField.algebraMap_eq, TensorProduct.smul_tmul'] + simp + have hdiff : ω - a • KaehlerDifferential.D k V t ∈ + maximalIdeal V • (⊤ : Submodule V (Ω[V⁄k])) := by + rw [← ker_residue_tensor_mk_one] + apply LinearMap.mem_ker.mpr + rw [map_sub, hfa, ← hz, sub_self] + rw [show ω = a • KaehlerDifferential.D k V t + + (ω - a • KaehlerDifferential.D k V t) by abel] + exact Submodule.add_mem _ + (Submodule.mem_sup_left (Submodule.smul_mem _ _ + (Submodule.subset_span (Set.mem_singleton _)))) + (Submodule.mem_sup_right hdiff) + · refine sup_le ?_ ?_ + · rw [Submodule.span_le] + rintro _ rfl + apply LinearMap.mem_ker.mpr + rw [KaehlerDifferential.map_D, + ResidueField.algebraMap_eq, + (IsLocalRing.residue_eq_zero_iff t).2 (hmax.symm ▸ Ideal.mem_span_singleton_self t)] + simp + · intro ω hω + apply LinearMap.mem_ker.mpr + have hf : f ω = 0 := by + rw [← LinearMap.mem_ker, ker_residue_tensor_mk_one] + exact hω + simpa [f, g, KaehlerDifferential.mapBaseChange_tmul] using + congrArg g hf + +/-- In characteristic zero, coordinate differentials span after an algebraic +extension of the field generated by the coordinates. -/ +theorem kaehler_span_of_isAlgebraic_adjoin + {k K : Type u} {ι : Type v} [Field k] [CharZero k] [Field K] [Algebra k K] + (q : ι → K) + (halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k (Set.range q) : IntermediateField k K) K) : + Submodule.span K + (Set.range fun i ↦ KaehlerDifferential.D k K (q i)) = ⊤ := by + let L : IntermediateField k K := + IntermediateField.adjoin k (Set.range q) + let qL : ι → L := fun i ↦ + ⟨q i, IntermediateField.subset_adjoin k (Set.range q) ⟨i, rfl⟩⟩ + letI : Algebra L K := L.toSubalgebra.toAlgebra + letI : IsScalarTower k L K := + IsScalarTower.of_algebraMap_eq (fun _ ↦ rfl) + letI : Algebra.IsAlgebraic L K := halg + letI : Algebra.IsSeparable L K := inferInstance + have hgenL : IntermediateField.adjoin k (Set.range qL) = ⊤ := by + apply top_unique + rintro ⟨z, hz⟩ - + apply IntermediateField.adjoin_induction k + (p := fun x hx ↦ + (⟨x, hx⟩ : L) ∈ IntermediateField.adjoin k (Set.range qL)) + · intro x hx + obtain ⟨i, rfl⟩ := hx + exact IntermediateField.subset_adjoin k _ ⟨i, rfl⟩ + · intro a + exact (IntermediateField.adjoin k (Set.range qL)).algebraMap_mem a + · intro a b _ _ ha hb + exact (IntermediateField.adjoin k (Set.range qL)).add_mem ha hb + · intro a _ ha + exact (IntermediateField.adjoin k (Set.range qL)).inv_mem ha + · intro a b _ _ ha hb + exact (IntermediateField.adjoin k (Set.range qL)).mul_mem ha hb + have hspan := + Stafford38.Geometry.KaehlerSpanSeparableAdjoin.kaehler_span_of_separable_adjoin_eq_top + (k := k) (E := L) (K := K) qL hgenL + simpa only [qL, IntermediateField.algebraMap_apply] using hspan + +/-- The source differential module is generated modulo the maximal ideal by +`d t` and the chosen coordinate differentials. -/ +theorem kaehler_le_coordinate_span_sup_maximalIdeal_smul + {k V : Type u} {ι : Type v} + [Field k] [CharZero k] [CommRing V] [IsLocalRing V] [Algebra k V] + (t : V) (hmax : maximalIdeal V = Ideal.span {t}) (q : ι → V) + (halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k + (Set.range fun i ↦ residue V (q i)) : + IntermediateField k (ResidueField V)) + (ResidueField V)) : + (⊤ : Submodule V (Ω[V⁄k])) ≤ + (Submodule.span V {KaehlerDifferential.D k V t} ⊔ + Submodule.span V + (Set.range fun i ↦ KaehlerDifferential.D k V (q i))) ⊔ + maximalIdeal V • (⊤ : Submodule V (Ω[V⁄k])) := by + let C : Submodule V (Ω[V⁄k]) := + Submodule.span V {KaehlerDifferential.D k V t} ⊔ + Submodule.span V (Set.range fun i ↦ KaehlerDifferential.D k V (q i)) + let S : Submodule (ResidueField V) (Ω[ResidueField V⁄k]) := + Submodule.span (ResidueField V) + (Set.range fun i ↦ KaehlerDifferential.D k (ResidueField V) (residue V (q i))) + have hS : S = ⊤ := kaehler_span_of_isAlgebraic_adjoin + (fun i ↦ residue V (q i)) halg + intro ω _ + have himage : KaehlerDifferential.map k k V (ResidueField V) ω ∈ S := by + rw [hS] + trivial + have hlift : ∀ z ∈ S, ∃ η ∈ C, + KaehlerDifferential.map k k V (ResidueField V) η = z := by + intro z hz + induction hz using Submodule.span_induction with + | mem z hz => + obtain ⟨i, rfl⟩ := hz + refine ⟨KaehlerDifferential.D k V (q i), ?_, ?_⟩ + · exact Submodule.mem_sup_right (Submodule.subset_span ⟨i, rfl⟩) + · rw [KaehlerDifferential.map_D, ResidueField.algebraMap_eq] + | zero => exact ⟨0, C.zero_mem, map_zero _⟩ + | add x y hx hy hx' hy' => + obtain ⟨x', hx'C, hx'map⟩ := hx' + obtain ⟨y', hy'C, hy'map⟩ := hy' + refine ⟨x' + y', C.add_mem hx'C hy'C, ?_⟩ + rw [map_add, hx'map, hy'map] + | smul a x hx hx' => + obtain ⟨x', hx'C, hx'map⟩ := hx' + obtain ⟨a', ha'⟩ := IsLocalRing.residue_surjective a + refine ⟨a' • x', C.smul_mem a' hx'C, ?_⟩ + rw [map_smul, hx'map] + change (algebraMap V (ResidueField V) a') • x = a • x + rw [ResidueField.algebraMap_eq, ha'] + obtain ⟨η, hηC, hη⟩ := hlift _ himage + have hker : ω - η ∈ LinearMap.ker + (KaehlerDifferential.map k k V (ResidueField V)) := by + apply LinearMap.mem_ker.mpr + rw [map_sub, hη, sub_self] + rw [ker_kaehler_residue_map_eq t hmax] at hker + obtain ⟨δ, hδdt, μ, hμm, hsum⟩ := Submodule.mem_sup.mp hker + rw [show ω = η + (δ + μ) by rw [hsum]; abel] + exact Submodule.add_mem _ + (Submodule.mem_sup_left hηC) + (Submodule.add_mem _ + (Submodule.mem_sup_left + (Submodule.mem_sup_left hδdt)) + (Submodule.mem_sup_right hμm)) + +/-- The image of `Ω[V/k]` in `Ω[F/k]` satisfies the visibility condition +for an independent generator `t` of the maximal ideal. -/ +theorem kaehler_image_visible + {k V F : Type u} {ι : Type v} + [Fintype ι] + [Field k] [CharZero k] [CommRing V] [IsLocalRing V] [Field F] + [Algebra k V] [Algebra k F] [Algebra V F] [IsScalarTower k V F] + (t : V) (hmax : maximalIdeal V = Ideal.span {t}) (q : ι → V) + (halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k + (Set.range fun i ↦ residue V (q i)) : + IntermediateField k (ResidueField V)) + (ResidueField V)) : + LinearMap.range (KaehlerDifferential.map k k V F) ≤ + Stafford38.Geometry.DivisorTangentLattice.coordinateFrame + (KaehlerDifferential.D k F) t q ⊔ + Ideal.span {t} • + LinearMap.range (KaehlerDifferential.map k k V F) := by + let φ : Ω[V⁄k] →ₗ[V] Ω[F⁄k] := + KaehlerDifferential.map k k V F + let C : Submodule V (Ω[V⁄k]) := + Submodule.span V {KaehlerDifferential.D k V t} ⊔ + Submodule.span V (Set.range fun i ↦ KaehlerDifferential.D k V (q i)) + let CF : Submodule V (Ω[F⁄k]) := + Stafford38.Geometry.DivisorTangentLattice.coordinateFrame + (KaehlerDifferential.D k F) t q + have hsource := kaehler_le_coordinate_span_sup_maximalIdeal_smul + t hmax q halg + have hcoord : C ≤ Submodule.comap φ CF := by + refine sup_le ?_ ?_ + · rw [Submodule.span_le, Set.singleton_subset_iff] + change φ (KaehlerDifferential.D k V t) ∈ CF + change KaehlerDifferential.map k k V F + (KaehlerDifferential.D k V t) ∈ CF + rw [KaehlerDifferential.map_D] + exact Submodule.mem_sup_left + (Submodule.subset_span (Set.mem_singleton _)) + · rw [Submodule.span_le] + rintro _ ⟨i, rfl⟩ + change φ (KaehlerDifferential.D k V (q i)) ∈ CF + change KaehlerDifferential.map k k V F + (KaehlerDifferential.D k V (q i)) ∈ CF + rw [KaehlerDifferential.map_D] + exact Stafford38.Geometry.DivisorTangentLattice.dQ_mem_coordinateFrame + (KaehlerDifferential.D k F) t q i + rintro w ⟨ω, rfl⟩ + have hω := hsource (show ω ∈ (⊤ : Submodule V (Ω[V⁄k])) from trivial) + rw [hmax] at hω + obtain ⟨η, hηC, μ, hμm, hsum⟩ := Submodule.mem_sup.mp hω + have hηCF : φ η ∈ CF := hcoord hηC + have hμW : φ μ ∈ Ideal.span {t} • LinearMap.range φ := by + have hmapped : φ μ ∈ Submodule.map φ + (Ideal.span {t} • (⊤ : Submodule V (Ω[V⁄k]))) := + Submodule.mem_map_of_mem hμm + rwa [Submodule.map_smul'', Submodule.map_top] at hmapped + rw [← hsum, map_add] + exact Submodule.add_mem _ + (Submodule.mem_sup_left hηCF) + (Submodule.mem_sup_right hμW) + +/-- Package the Kähler image as the lattice of a visible divisor frame once +the independent DVR and projective-order data have been supplied. -/ +theorem exists_visibleDivisorFrame_of_kaehler_image + {k V F : Type u} {ι : Type v} + [Fintype ι] + [Field k] [CharZero k] [CommRing V] [IsLocalRing V] [Field F] + [Algebra k V] [Algebra k F] [Algebra V F] [IsScalarTower k V F] + [Module.Finite V (Ω[V⁄k])] + (Q₀ Q₁ t u w : V) (Q : ι → V) (a e : ℕ) (j₀ : ι) + (hmax : maximalIdeal V = Ideal.span {t}) + (t_ne : t ≠ 0) (u_unit : IsUnit u) + (one_le_a : 1 ≤ a) (one_le_e : 1 ≤ e) + (Q₀_eq : Q₀ = t ^ a * u) (Q₁_eq : Q₁ = t ^ (a + e) * w) + (Q_j₀ : Q j₀ = 1) + (halg : Algebra.IsAlgebraic + (IntermediateField.adjoin k + (Set.range fun i ↦ residue V (Q i)) : + IntermediateField k (ResidueField V)) + (ResidueField V)) : + ∃ D : Stafford38.Geometry.DivisorTangentLattice.VisibleDivisorFrame + (V := V) (KaehlerDifferential.D k F) ι, + D.Q₀ = Q₀ ∧ D.Q₁ = Q₁ ∧ D.t = t ∧ D.u = u ∧ D.w = w ∧ + D.Q = Q ∧ D.a = a ∧ D.e = e ∧ D.j₀ = j₀ ∧ + D.W = LinearMap.range (KaehlerDifferential.map k k V F) := by + let φ : Ω[V⁄k] →ₗ[V] Ω[F⁄k] := + KaehlerDifferential.map k k V F + have W_fg : (LinearMap.range φ).FG := by + rw [LinearMap.range_eq_map] + exact Module.Finite.fg_top.map φ + let D : Stafford38.Geometry.DivisorTangentLattice.VisibleDivisorFrame + (V := V) (KaehlerDifferential.D k F) ι := + { Q₀ := Q₀ + Q₁ := Q₁ + t := t + u := u + w := w + Q := Q + a := a + e := e + j₀ := j₀ + W := LinearMap.range φ + t_mem := hmax.symm ▸ Ideal.mem_span_singleton_self t + t_ne := t_ne + u_unit := u_unit + a_unit := by + have hak : (a : k) ≠ 0 := Nat.cast_ne_zero.mpr + (Nat.ne_of_gt (lt_of_lt_of_le Nat.zero_lt_one one_le_a)) + exact_mod_cast (isUnit_iff_ne_zero.mpr hak).map (algebraMap k V) + one_le_a := one_le_a + one_le_e := one_le_e + Q₀_eq := Q₀_eq + Q₁_eq := Q₁_eq + Q_j₀ := Q_j₀ + W_fg := W_fg + dt_mem := ⟨KaehlerDifferential.D k V t, by + simp only [φ, KaehlerDifferential.map_D]⟩ + du_mem := ⟨KaehlerDifferential.D k V u, by + simp only [φ, KaehlerDifferential.map_D]⟩ + dw_mem := ⟨KaehlerDifferential.D k V w, by + simp only [φ, KaehlerDifferential.map_D]⟩ + dQ_mem := fun j ↦ ⟨KaehlerDifferential.D k V (Q j), by + simp only [φ, KaehlerDifferential.map_D]⟩ + visible := kaehler_image_visible t hmax Q halg } + exact ⟨D, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + + +end + +end Stafford38.Geometry.KaehlerDVRVisibility diff --git a/LeanPool/Stafford38/Stafford38/Geometry/KaehlerSpanSeparableAdjoin.lean b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerSpanSeparableAdjoin.lean new file mode 100644 index 0000000000..79457a2bd5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerSpanSeparableAdjoin.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.SeparableResidueDerivationExtension +import LeanPool.Stafford38.Stafford38.Geometry.KaehlerVisibleDerivationFrame + +/-! +# Kähler span after a separable residue-field extension + +Let `k → E → K` be a tower of fields. If a family `q : ι → E` generates +`E` as an intermediate field over `k`, then its universal differentials span +`Ω[E⁄k]`. If `K/E` is formally étale, the images of the same differentials +span `Ω[K⁄k]`; separability supplies the formally-étale instance for fields. + +For a finite generating family, this also supplies the finite-dimensional +instance needed by `KaehlerVisibleDerivationFrame` and hence a dual visible +derivation frame over `K`. + +This file does not construct a projective boundary divisor, prove that the +residue coordinates at a chosen divisor generate an intermediate field, or +produce any completed boundary chart. Those are separate geometric inputs. +-/ + +namespace Stafford38.Geometry.KaehlerSpanSeparableAdjoin + +open TensorProduct + +noncomputable section + +universe u v + +variable {k E K : Type u} [Field k] [Field E] [Field K] +variable [Algebra k E] [Algebra k K] [Algebra E K] +variable [IsScalarTower k E K] + +/-- A family that generates a field over the ground field has universal +differentials spanning the full Kähler module. -/ +theorem kaehler_span_of_intermediateField_adjoin_eq_top + {ι : Type v} (q : ι → E) + (hgen : IntermediateField.adjoin k (Set.range q) = ⊤) : + Submodule.span E + (Set.range fun i ↦ KaehlerDifferential.D k E (q i)) = ⊤ := by + let W : Submodule E (Ω[E⁄k]) := + Submodule.span E (Set.range fun i ↦ KaehlerDifferential.D k E (q i)) + have hD (x : E) : KaehlerDifferential.D k E x ∈ W := by + have hx : x ∈ IntermediateField.adjoin k (Set.range q) := by + rw [hgen] + trivial + apply IntermediateField.adjoin_induction k + (p := fun y _ ↦ KaehlerDifferential.D k E y ∈ W) + · intro y hy + change y ∈ Set.range q at hy + obtain ⟨i, rfl⟩ := hy + exact Submodule.subset_span ⟨i, rfl⟩ + · intro a + simp + · intro a b _ _ ha hb + simpa only [map_add] using W.add_mem ha hb + · intro a _ ha + rw [Derivation.leibniz_inv] + exact W.smul_mem _ ha + · intro a b _ _ ha hb + rw [Derivation.leibniz] + exact W.add_mem (W.smul_mem _ hb) (W.smul_mem _ ha) + · exact hx + apply top_unique + rw [← KaehlerDifferential.span_range_derivation, Submodule.span_le] + rintro _ ⟨x, rfl⟩ + exact hD x + +/-- Formally-étale base change transports a field-generating differential +family to a spanning family over the extension field. -/ +theorem kaehler_span_of_formallyEtale_adjoin_eq_top + [Algebra.FormallyEtale E K] + {ι : Type v} (q : ι → E) + (hgen : IntermediateField.adjoin k (Set.range q) = ⊤) : + Submodule.span K + (Set.range fun i ↦ + KaehlerDifferential.D k K (algebraMap E K (q i))) = ⊤ := by + let W : Submodule K (Ω[K⁄k]) := + Submodule.span K (Set.range fun i ↦ + KaehlerDifferential.D k K (algebraMap E K (q i))) + have hE : Submodule.span E + (Set.range fun i ↦ KaehlerDifferential.D k E (q i)) = ⊤ := + kaehler_span_of_intermediateField_adjoin_eq_top q hgen + have hmap (w : Ω[E⁄k]) : + KaehlerDifferential.map k k E K w ∈ W := by + have hw : w ∈ Submodule.span E + (Set.range fun i ↦ KaehlerDifferential.D k E (q i)) := by + rw [hE] + trivial + induction hw using Submodule.span_induction with + | mem x hx => + obtain ⟨i, rfl⟩ := hx + rw [KaehlerDifferential.map_D] + exact Submodule.subset_span ⟨i, rfl⟩ + | zero => exact W.zero_mem + | add x y hx hy hx' hy' => + simpa only [map_add] using W.add_mem hx' hy' + | smul a x hx hx' => + simpa only [LinearMap.map_smul_of_tower, + IsScalarTower.algebraMap_smul] using + W.smul_mem (algebraMap E K a) hx' + let e := KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale k E K + have he (y : K ⊗[E] Ω[E⁄k]) : e y ∈ W := by + induction y using TensorProduct.induction_on with + | zero => + rw [show e (0 : K ⊗[E] Ω[E⁄k]) = 0 from e.map_zero] + exact W.zero_mem + | add x y hx hy => + simpa only [map_add] using W.add_mem hx hy + | tmul a w => + rw [KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_apply, + KaehlerDifferential.mapBaseChange_tmul] + exact W.smul_mem _ (hmap w) + apply top_unique + intro z _ + obtain ⟨y, rfl⟩ := e.surjective z + exact he y + +/-- The formally-étale span theorem specialized to a separable extension of +fields. No finite-degree hypothesis is needed. -/ +theorem kaehler_span_of_separable_adjoin_eq_top + [Algebra.IsSeparable E K] + {ι : Type v} (q : ι → E) + (hgen : IntermediateField.adjoin k (Set.range q) = ⊤) : + Submodule.span K + (Set.range fun i ↦ + KaehlerDifferential.D k K (algebraMap E K (q i))) = ⊤ := by + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + exact kaehler_span_of_formallyEtale_adjoin_eq_top q hgen + +/-- A finite field-generating family gives a visible dual derivation frame +after separable extension. -/ +theorem exists_visible_derivation_frame_of_finite_separable_adjoin + [Algebra.IsSeparable E K] + {ι : Type v} [Fintype ι] (q : ι → E) + (hgen : IntermediateField.adjoin k (Set.range q) = ⊤) : + ∃ (rows : Fin (Module.finrank K (Ω[K⁄k])) ↪ ι) + (D : Fin (Module.finrank K (Ω[K⁄k])) → Derivation k K K), + ∀ i j, D j (algebraMap E K (q (rows i))) = + if i = j then 1 else 0 := by + have hspan := kaehler_span_of_separable_adjoin_eq_top + (k := k) (E := E) (K := K) q hgen + letI : FiniteDimensional K (Ω[K⁄k]) := by + letI : FiniteDimensional K + (Submodule.span K (Set.range fun i ↦ + KaehlerDifferential.D k K (algebraMap E K (q i)))) := + FiniteDimensional.span_of_finite K (Set.finite_range _) + letI : FiniteDimensional K (⊤ : Submodule K (Ω[K⁄k])) := + (LinearEquiv.ofEq _ _ hspan).finiteDimensional + exact Submodule.topEquiv.finiteDimensional + exact Stafford38.Geometry.KaehlerVisibleDerivationFrame.exists_visible_derivation_frame_of_kaehler_span + (fun i ↦ algebraMap E K (q i)) hspan + + +end + +end Stafford38.Geometry.KaehlerSpanSeparableAdjoin diff --git a/LeanPool/Stafford38/Stafford38/Geometry/KaehlerVisibleDerivationFrame.lean b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerVisibleDerivationFrame.lean new file mode 100644 index 0000000000..54f16a54d5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/KaehlerVisibleDerivationFrame.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +import LeanPool.Stafford38.Stafford38.Geometry.ResidueMinorSelection +import Mathlib.LinearAlgebra.Basis.VectorSpace + +/-! +# Derivation frames visible in residue coordinates + +Let `K/k` be a field extension and let `qbar i : K` be a finite family whose +Kähler differentials span `Ω[K/k]`. A basis can then be selected from that +family. Its dual coordinate maps correspond, by the universal property of +Kähler differentials, to `k`-derivations of `K`. These derivations evaluate +on the selected coordinates as the Kronecker delta. + +Applying the derivations coefficientwise to power-series lifts of the +coordinates gives a selected residue minor whose determinant has constant +coefficient exactly one. + +This file assumes the spanning hypothesis. In particular, it does not claim +that an arbitrary retained DVR or boundary place supplies it. +-/ + +namespace Stafford38.Geometry.KaehlerVisibleDerivationFrame + +open Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +open Stafford38.GeometryResidueMinorSelection +open Stafford38.GeometrySplitTangentMatrix + +noncomputable section + +universe u v + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] + +/-- If finitely many residue coordinates span the Kähler differentials, one +can select a basis among them and choose dual derivations. -/ +theorem exists_visible_derivation_frame_of_kaehler_span + {iota : Type v} [Fintype iota] + [FiniteDimensional K (Ω[K⁄k])] + (qbar : iota → K) + (hspan : + Submodule.span K + (Set.range fun i ↦ KaehlerDifferential.D k K (qbar i)) = ⊤) : + ∃ (rows : Fin (Module.finrank K (Ω[K⁄k])) ↪ iota) + (D : Fin (Module.finrank K (Ω[K⁄k])) → Derivation k K K), + ∀ i j, D j (qbar (rows i)) = if i = j then 1 else 0 := by + let b := Module.Basis.ofSpan (K := K) + (s := Set.range fun i ↦ KaehlerDifferential.D k K (qbar i)) hspan.ge + letI : Fintype ((linearIndepOn_empty K (id : Ω[K⁄k] → Ω[K⁄k])).extend + (Set.empty_subset + (Set.range fun i ↦ KaehlerDifferential.D k K (qbar i)))) := + Fintype.ofFinite _ + let e : Fin (Module.finrank K (Ω[K⁄k])) ≃ + ((linearIndepOn_empty K (id : Ω[K⁄k] → Ω[K⁄k])).extend + (Set.empty_subset + (Set.range fun i ↦ KaehlerDifferential.D k K (qbar i)))) := + Fintype.equivOfCardEq (by + rw [Fintype.card_fin, ← Module.finrank_eq_card_basis b]) + have hb_range (a : Fin (Module.finrank K (Ω[K⁄k]))) : + b (e a) ∈ + Set.range fun i ↦ KaehlerDifferential.D k K (qbar i) := + Module.Basis.ofSpan_subset (K := K) (V := Ω[K⁄k]) hspan.ge ⟨e a, rfl⟩ + let row (a : Fin (Module.finrank K (Ω[K⁄k]))) : iota := + Classical.choose (hb_range a) + have hrow (a : Fin (Module.finrank K (Ω[K⁄k]))) : + KaehlerDifferential.D k K (qbar (row a)) = b (e a) := + Classical.choose_spec (hb_range a) + have hrow_injective : Function.Injective row := by + intro a₁ a₂ h + apply e.injective + apply b.injective + rw [← hrow a₁, ← hrow a₂, h] + let rows : Fin (Module.finrank K (Ω[K⁄k])) ↪ iota := + ⟨row, hrow_injective⟩ + let D (j : Fin (Module.finrank K (Ω[K⁄k]))) : Derivation k K K := + KaehlerDifferential.linearMapEquivDerivation k K (b.coord (e j)) + refine ⟨rows, D, ?_⟩ + intro i j + rw [show qbar (rows i) = qbar (row i) by rfl] + rw [show D j (qbar (row i)) = + b.coord (e j) (KaehlerDifferential.D k K (qbar (row i))) by + simp [D]] + rw [hrow] + by_cases hij : i = j + · subst j + simp + · have heij : e i ≠ e j := fun h ↦ hij (e.injective h) + simp [heij, hij] + +/-- Coefficientwise application of a family of residue-field derivations to +power-series coordinates. -/ +noncomputable def coefficientwiseTangentMatrix + {iota kappa : Type*} + (q : iota → PowerSeries K) (D : kappa → Derivation k K K) : + Matrix iota kappa (PowerSeries K) := + fun i j ↦ coefficientwiseDerivation (D j) (q i) + +@[simp] +theorem constantCoeff_coefficientwiseTangentMatrix + {iota kappa : Type*} + (q : iota → PowerSeries K) (D : kappa → Derivation k K K) + (i : iota) (j : kappa) : + PowerSeries.constantCoeff (coefficientwiseTangentMatrix q D i j) = + D j (PowerSeries.constantCoeff (q i)) := by + rw [coefficientwiseTangentMatrix, + ← PowerSeries.coeff_zero_eq_constantCoeff] + exact coeff_coefficientwiseDerivation (D j) (q i) 0 + +/-- Under the Kähler-span hypothesis, coefficientwise derivations furnish a +selected power-series minor with constant coefficient exactly one. -/ +theorem exists_coefficientwise_selectedMinor_constantCoeff_eq_one_of_kaehler_span + {iota : Type v} [Fintype iota] + [FiniteDimensional K (Ω[K⁄k])] + (q : iota → PowerSeries K) + (hspan : + Submodule.span K + (Set.range fun i ↦ KaehlerDifferential.D k K + (PowerSeries.constantCoeff (q i))) = ⊤) : + ∃ (rows : Fin (Module.finrank K (Ω[K⁄k])) ↪ iota) + (D : Fin (Module.finrank K (Ω[K⁄k])) → Derivation k K K), + (∀ i j, + D j (PowerSeries.constantCoeff (q (rows i))) = + if i = j then 1 else 0) ∧ + PowerSeries.constantCoeff + (selectedMinor (coefficientwiseTangentMatrix q D) rows).det = 1 := by + obtain ⟨rows, D, hD⟩ := + exists_visible_derivation_frame_of_kaehler_span + (fun i ↦ PowerSeries.constantCoeff (q i)) hspan + refine ⟨rows, D, hD, ?_⟩ + rw [constantCoeff_selectedMinor_det] + have hmatrix : + selectedMinor + (residueMatrix (coefficientwiseTangentMatrix q D)) rows = + (1 : Matrix (Fin (Module.finrank K (Ω[K⁄k]))) + (Fin (Module.finrank K (Ω[K⁄k]))) K) := by + ext i j + simpa [selectedMinor, residueMatrix, Matrix.one_apply, + constantCoeff_coefficientwiseTangentMatrix] using hD i j + rw [hmatrix, Matrix.det_one] + + +end + +end Stafford38.Geometry.KaehlerVisibleDerivationFrame diff --git a/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalDirection.lean b/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalDirection.lean new file mode 100644 index 0000000000..1d9e50668d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalDirection.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.LaurentSeries +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization +import LeanPool.Stafford38.Stafford38.Geometry.ScalarExtensionPoints + +/-! +# Laurent specialization of projected conormal directions + +A Laurent-valued phase point need not specialize to a finite phase point: its +base coordinates may have poles. Its fibre coordinates can nevertheless be +regular power series. This file records exactly the consequence that survives: +the residue of those fibre coordinates belongs to the ground-coefficient +vanishing hull of the projected fibre image. + +The construction is then specialized to the scalar-extended +`equationConormalLocus`. The final theorem is the corresponding direct +polynomial obstruction for a ground-field symbol using only fibre variables. + +No full phase-space closure, compatibility of closure with base change, +normalization chart, asymptotic-conormal producer, or Gabber theorem is proved +here. +-/ + +namespace Stafford38.Geometry.LaurentConormalDirection + +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {k K : Type*} [Field k] [Field K] [Algebra k K] +variable {n : ℕ} + +/-- Forget the base coordinate of a set of phase points. -/ +def fibreImage (S : Set (PhaseVar n → K)) : Set (Fin n → K) := + (fun q i ↦ q (Sum.inr i)) '' S + +/-- The ground-field affine vanishing hull of the fibre directions of a set +of extension-valued phase points. Both projection and extension-valued +vanishing are explicit; this is not a full phase-space closure. -/ +def extensionFibreClosure (S : Set (PhaseVar n → K)) : Set (Fin n → k) := + MvPolynomial.zeroLocus k + (extensionValuedVanishingIdeal (k := k) (K := K) (fibreImage S)) + +/-- Evaluating a ground-field polynomial on power-series coordinates and then +embedding in Laurent series is the same as evaluating directly on the +embedded Laurent coordinates. -/ +theorem algebraMap_eval_powerSeries_eq_eval₂_laurent + (P : MvPolynomial (Fin n) k) (xi : Fin n → PowerSeries k) : + algebraMap (PowerSeries k) (LaurentSeries k) + (MvPolynomial.eval xi (MvPolynomial.map (PowerSeries.C) P)) = + MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) P := by + have hcoeff : + (algebraMap (PowerSeries k) (LaurentSeries k)).comp + (PowerSeries.C) = + algebraMap k (LaurentSeries k) := by + ext r + simp [LaurentSeries.algebraMap_apply] + rw [MvPolynomial.eval_map, MvPolynomial.eval₂_comp_left, hcoeff] + rfl + +/-- A Laurent-valued phase point whose fibre coordinates are regular power +series specializes, after forgetting its possibly singular base coordinate, +to the ground-field extension-valued vanishing hull of the projected fibre +image. -/ +theorem residue_mem_extensionFibreClosure_of_laurent_generic + (S : Set (PhaseVar n → LaurentSeries k)) + (y : Fin n → LaurentSeries k) + (xi : Fin n → PowerSeries k) + (hgeneric : + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ S) : + residueColumn xi ∈ + extensionFibreClosure (k := k) (K := LaurentSeries k) S := by + rw [extensionFibreClosure, MvPolynomial.mem_zeroLocus_iff] + intro P hP + have hzeroLaurent : + MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) P = 0 := by + apply (mem_extensionValuedVanishingIdeal_iff + (k := k) (K := LaurentSeries k) (fibreImage S) P).mp hP + exact ⟨Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)), + hgeneric, rfl⟩ + have hzeroPowerSeries : + MvPolynomial.eval xi (MvPolynomial.map (PowerSeries.C) P) = 0 := by + apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) + change algebraMap (PowerSeries k) (LaurentSeries k) + (MvPolynomial.eval xi (MvPolynomial.map (PowerSeries.C) P)) = + algebraMap (PowerSeries k) (LaurentSeries k) 0 + rw [map_zero, algebraMap_eval_powerSeries_eq_eval₂_laurent] + exact hzeroLaurent + exact residue_eval_eq_zero_of_eval_map_eq_zero P xi hzeroPowerSeries + +/-- The projected Laurent-direction hull of the scalar-extended +equation-defined conormal locus. -/ +def laurentEquationConormalDirectionClosure + (I : Ideal (MvPolynomial (Fin n) k)) : Set (Fin n → k) := + extensionFibreClosure (k := k) (K := LaurentSeries k) + (equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) + +/-- Projected-direction specialization for a Laurent-valued point of the +scalar-extended equation conormal locus. -/ +theorem residue_mem_laurentEquationConormalDirectionClosure + (I : Ideal (MvPolynomial (Fin n) k)) + (y : Fin n → LaurentSeries k) + (xi : Fin n → PowerSeries k) + (hgeneric : + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) : + residueColumn xi ∈ laurentEquationConormalDirectionClosure I := by + exact residue_mem_extensionFibreClosure_of_laurent_generic + (S := equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) + y xi hgeneric + +/-- Embed a ground-field polynomial in fibre variables as a fibre-only phase +symbol. -/ +def fibreLift (P : MvPolynomial (Fin n) k) : SymbolRing k n := + MvPolynomial.rename Sum.inr P + +/-- Evaluation of a fibre-only phase symbol ignores the base coordinate. -/ +theorem eval₂_fibreLift + (P : MvPolynomial (Fin n) k) + (y xi : Fin n → K) : + MvPolynomial.eval₂ (algebraMap k K) (Sum.elim y xi) (fibreLift P) = + MvPolynomial.eval₂ (algebraMap k K) xi P := by + rw [fibreLift, MvPolynomial.eval₂_rename] + rfl + +/-- Direct projected-direction contradiction. A fibre-only ground-field +symbol cannot both evaluate to one on the residue axis and vanish on a +Laurent generic conormal direction whose fibre coordinates have that residue. + +The conormal hypothesis is used only to place the generic fibre in the +projected set; no specialization of its base coordinate is asserted. -/ +theorem false_of_fibreOnly_symbol_one_on_residue_and_vanishes_on_laurentConormal + (I : Ideal (MvPolynomial (Fin n) k)) + (P : MvPolynomial (Fin n) k) + (axis : Fin n → k) + (y : Fin n → LaurentSeries k) + (xi : Fin n → PowerSeries k) + (hgeneric : + Sum.elim y + (fun i ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi i)) ∈ + equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)))) + (hresidue : residueColumn xi = axis) + (hvanishes : + ∀ q ∈ equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))), + MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) q + (fibreLift P) = 0) + (haxis : MvPolynomial.eval axis P = 1) : False := by + let S : Set (PhaseVar n → LaurentSeries k) := + equationConormalLocus + (I.map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + have hP : + P ∈ extensionValuedVanishingIdeal + (k := k) (K := LaurentSeries k) (fibreImage S) := by + rw [mem_extensionValuedVanishingIdeal_iff] + intro v hv + rcases hv with ⟨q, hq, rfl⟩ + rw [← eval₂_fibreLift P (fun i ↦ q (Sum.inl i))] + have hsplit : + Sum.elim (fun i ↦ q (Sum.inl i)) (fun i ↦ q (Sum.inr i)) = q := by + funext i + rcases i with i | i <;> rfl + rw [hsplit] + exact hvanishes q hq + have hresidueInHull : + residueColumn xi ∈ + extensionFibreClosure (k := k) (K := LaurentSeries k) S := + residue_mem_extensionFibreClosure_of_laurent_generic + (S := S) y xi hgeneric + rw [extensionFibreClosure, MvPolynomial.mem_zeroLocus_iff] at hresidueInHull + have hzeroResidue := hresidueInHull P hP + rw [hresidue, MvPolynomial.aeval_eq_eval, haxis] at hzeroResidue + exact one_ne_zero hzeroResidue + +/-! The declarations below make the scope boundary executable: projection +forgets arbitrary base coordinates, whereas membership in a full phase set +still retains them. In particular no converse reconstructing a finite phase +specialization is available from `fibreImage`. -/ + +theorem fibre_mem_fibreImage_of_phase_mem + (S : Set (PhaseVar n → K)) (q : PhaseVar n → K) (hq : q ∈ S) : + (fun i ↦ q (Sum.inr i)) ∈ fibreImage S := + ⟨q, hq, rfl⟩ + + +end + +end Stafford38.Geometry.LaurentConormalDirection diff --git a/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalResidueExtension.lean b/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalResidueExtension.lean new file mode 100644 index 0000000000..c059af76fe --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/LaurentConormalResidueExtension.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveDivisorOrderGap +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveEquationFormalChart +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveTangentInclusion + +/-! +# Laurent conormal specialization over a residue-field extension + +The residue field of a divisorial valuation need not be the original ground +field. This file separates the two coefficient roles which are easy to +confuse in that situation: + +* `k` is the field of coefficients of the original equations and symbol; +* `K` is the residue field of the boundary valuation, and the completed + coordinates live in `PowerSeries K` and `LaurentSeries K`. + +Ground coefficients are sent to Laurent series by the displayed composite +`k -> K -> LaurentSeries K`. The fibre closure itself is taken over `K`. +The resulting contradiction uses only field and algebra-tower structure; in +particular it does not require `K` to be algebraically closed and does not +choose a map `K -> k`. + +The final structure and consumer are a residue-extension version of the +completed-boundary local interface. They construct no projective chart, +normalization, divisor, or tangent comparison. +-/ + +namespace Stafford38.Geometry.LaurentConormalResidueExtension + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ProjectiveDivisorOrderGap +open Stafford38.Geometry.ProjectiveEquationFormalChart +open Stafford38.Geometry.ProjectiveTangentInclusion +open Stafford38.GeometryPowerSeriesTangentLimit +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometrySplitTangentMatrix +open Stafford38.Geometry.FormalDivisorLaurentConormal + +noncomputable section + +universe u + +variable {k K : Type u} [Field k] [Field K] [Algebra k K] +variable {n : ℕ} + +/-! ## The coefficient tower -/ + +/-- The coefficient map used by equations over the ground field after +completion at a boundary with residue field `K`. -/ +def groundLaurentMap : k →+* LaurentSeries K := + (algebraMap K (LaurentSeries K)).comp (algebraMap k K) + +/-- Ground-field polynomials evaluated in the completed residue-field +Laurent series ring. -/ +def groundPolynomialMap (σ : Type*) : + MvPolynomial σ k →+* MvPolynomial σ (LaurentSeries K) := + MvPolynomial.map (groundLaurentMap (k := k) (K := K)) + +/-- The same ground polynomial after first extending its coefficients to the +residue field. -/ +def residuePolynomialMap (σ : Type*) : + MvPolynomial σ k →+* MvPolynomial σ K := + MvPolynomial.map (algebraMap k K) + +/-- Fibre lift after extending the ground coefficients to `K`. -/ +def residueFibreLift (P : MvPolynomial (Fin n) k) : + MvPolynomial (PhaseVar n) K := + fibreLift (residuePolynomialMap (k := k) (K := K) (Fin n) P) + +/-- The two routes from a ground-field fibre polynomial to Laurent series +agree exactly: extend to `K` first or map directly along the composite. -/ +theorem eval_residueFibreLift_eq_ground + (P : MvPolynomial (Fin n) k) + (q : PhaseVar n → LaurentSeries K) : + MvPolynomial.eval₂ (algebraMap K (LaurentSeries K)) q + (residueFibreLift (k := k) (K := K) P) = + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) := by + change MvPolynomial.eval₂ (algebraMap K (LaurentSeries K)) q + (MvPolynomial.rename Sum.inr + (MvPolynomial.map (algebraMap k K) P)) = _ + rw [← MvPolynomial.map_rename] + rw [MvPolynomial.eval₂_map] + rfl + +/-- Evaluation of a ground polynomial agrees with evaluation of its +coefficient extension along the residue-field-to-Laurent map. -/ +theorem eval_residuePolynomialMap_eq_ground + (P : MvPolynomial (Fin n) k) + (v : Fin n → LaurentSeries K) : + MvPolynomial.eval₂ (algebraMap K (LaurentSeries K)) v + (residuePolynomialMap (k := k) (K := K) (Fin n) P) = + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) v P := by + change MvPolynomial.eval₂ (algebraMap K (LaurentSeries K)) v + (MvPolynomial.map (algebraMap k K) P) = _ + rw [MvPolynomial.eval₂_map] + rfl + +/-- Fibre-only evaluation ignores the base part of a phase point, also for +the explicit ground-to-Laurent coefficient map. -/ +theorem eval_ground_fibreLift + (P : MvPolynomial (Fin n) k) + (q : PhaseVar n → LaurentSeries K) : + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) + (fun i ↦ q (Sum.inr i)) P := by + rw [fibreLift, MvPolynomial.eval₂_rename] + rfl + +/-! ## Fibre closure over the residue field -/ + +/-- The projected closure of Laurent-valued phase points, with regular fibre +residue, formed over `K`. Its base coordinates may have poles. -/ +def residueExtensionFibreClosure + (S : Set (PhaseVar n → LaurentSeries K)) : Set (Fin n → K) := + extensionFibreClosure (k := K) (K := LaurentSeries K) S + +/-- The existing Laurent-residue theorem, instantiated over the residue field +`K`. No algebraic-closedness hypothesis occurs. -/ +theorem residue_mem_residueExtensionFibreClosure_of_laurent_generic + (S : Set (PhaseVar n → LaurentSeries K)) + (y : Fin n → LaurentSeries K) + (xi : Fin n → PowerSeries K) + (hgeneric : + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ S) : + residueColumn xi ∈ residueExtensionFibreClosure (K := K) S := by + exact residue_mem_extensionFibreClosure_of_laurent_generic + (k := K) S y xi hgeneric + +/-! ## Ground-field contradiction -/ + +/-- The scalar-extended equation-conormal locus associated with a ground +ideal. Its coefficients use the explicit composite `k -> K -> Laurent`. -/ +def groundEquationConormalLocus + (I : Ideal (MvPolynomial (Fin n) k)) : + Set (PhaseVar n → LaurentSeries K) := + equationConormalLocus + (I.map (groundPolynomialMap (k := k) (K := K) (Fin n))) + +/-- A fibre-only ground polynomial which vanishes on the whole completed +equation-conormal locus also vanishes after extending its coefficients to +`K` and evaluating at every regular fibre residue. -/ +theorem residueFibreLift_mem_extensionValuedVanishingIdeal_of_ground_vanishing + (I : Ideal (MvPolynomial (Fin n) k)) + (P : MvPolynomial (Fin n) k) + (hvanishes : + ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) I, + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = 0) : + residuePolynomialMap (k := k) (K := K) (Fin n) P ∈ + extensionValuedVanishingIdeal (k := K) (K := LaurentSeries K) + (fibreImage (groundEquationConormalLocus (k := k) (K := K) I)) := by + rw [mem_extensionValuedVanishingIdeal_iff] + intro q hq + rcases hq with ⟨z, hz, rfl⟩ + rw [eval_residuePolynomialMap_eq_ground] + rw [← eval_ground_fibreLift] + exact hvanishes z hz + +/-- Exact contradiction consumer for a residue-field-valued boundary arc. + +The hypotheses deliberately use the composite coefficient map and an +`eval₂ (algebraMap k K)` axis value. The theorem requires neither +`IsAlgClosed K` nor a retraction from `K` to `k`. -/ +theorem false_of_ground_fibreOnly_symbol_one_on_residue_and_vanishing + (I : Ideal (MvPolynomial (Fin n) k)) + (P : MvPolynomial (Fin n) k) + (axis : Fin n → K) + (y : Fin n → LaurentSeries K) + (xi : Fin n → PowerSeries K) + (hgeneric : + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I) + (hresidue : residueColumn xi = axis) + (hvanishes : + ∀ q ∈ groundEquationConormalLocus (k := k) (K := K) I, + MvPolynomial.eval₂ (groundLaurentMap (k := k) (K := K)) q + (fibreLift P) = 0) + (haxis : MvPolynomial.eval₂ (algebraMap k K) axis P = 1) : False := by + let S : Set (PhaseVar n → LaurentSeries K) := + groundEquationConormalLocus (k := k) (K := K) I + have hP : + residuePolynomialMap (k := k) (K := K) (Fin n) P ∈ + extensionValuedVanishingIdeal (k := K) (K := LaurentSeries K) + (fibreImage S) := by + exact residueFibreLift_mem_extensionValuedVanishingIdeal_of_ground_vanishing + (k := k) (K := K) I P (by + simpa [S] using hvanishes) + have hclosure : + residueColumn xi ∈ residueExtensionFibreClosure (K := K) S := + residue_mem_residueExtensionFibreClosure_of_laurent_generic + (K := K) S y xi (by simpa [S] using hgeneric) + have hzero : + MvPolynomial.eval (residueColumn xi) + (residuePolynomialMap (k := k) (K := K) (Fin n) P) = 0 := + hclosure _ hP + have hzero' : + MvPolynomial.eval₂ (algebraMap k K) (residueColumn xi) P = 0 := by + simpa [residuePolynomialMap] using hzero + rw [hresidue, haxis] at hzero' + exact one_ne_zero hzero' + +/-! ## Completed-boundary adapter over `K` -/ + +/-- A completed projective boundary chart whose residue coefficients are in +`K`, while the target affine ideal remains defined over `k`. Its formal +tangent data are one fixed derivative-compatible geometric witness. The +one-sided tangent inclusion uses that same stored transverse column, never an +alternative split column. -/ +structure CompletedProjectiveBoundaryChartOver + (m : ℕ) (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) where + equationCount : ℕ + tangentCount : ℕ + equations : Fin equationCount → + MvPolynomial (Fin (m + 1)) (LaurentSeries K) + degree : Fin equationCount → ℕ + homogeneous : ∀ j, (equations j).IsHomogeneous (degree j) + q : Fin (m + 1) → PowerSeries K + Z : Matrix (Fin (m + 1)) (Fin tangentCount) (PowerSeries K) + rows : Fin tangentCount ↪ Fin (m + 1) + chart : Fin (m + 1) + zero : Fin (m + 1) + axis : Fin (m + 1) + ratio : PowerSeries K + q_chart : q chart = 1 + Z_chart : ∀ j, Z chart j = 0 + q_zero_ne : q zero ≠ 0 + q_origin_ne : q 0 ≠ 0 + ratio_ne : ratio ≠ 0 + q_zero_vanish : PowerSeries.constantCoeff (q zero) = 0 + ratio_vanish : PowerSeries.constantCoeff ratio = 0 + q_axis : q axis = q zero * ratio + Z_zero_dvd : ∀ j, q zero ∣ Z zero j + Z_axis_dvd : ∀ j, q axis ∣ Z axis j + selected_minor_nonzero : + PowerSeries.constantCoeff (selectedMinor Z rows).det ≠ 0 + equations_vanish : + ∀ j, MvPolynomial.eval (laurentColumn q) (equations j) = 0 + ideal_containment : + I.map (groundPolynomialMap (k := k) (K := K) (Fin m)) ≤ + dehomogenizedEquationIdeal equations + axis_is_first_fibre : axis = Fin.succ ⟨0, hm⟩ + tau : Fin (m + 1) → PowerSeries K + C : Matrix (FormalTangentColumn (Fin tangentCount)) + (Fin (m + 1)) (PowerSeries K) + ell : Fin (m + 1) → PowerSeries K + left_inverse : C * formalTangentMatrix q Z tau = 1 + annihilation : rowMul ell (formalTangentMatrix q Z tau) = 0 + residue_axis : residueColumn ell = axisRow (k := K) axis + tangent_inclusion : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (groundPolynomialMap (k := k) (K := K) (Fin m))) ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) + +/-- The residue-extension completed chart supplies a Laurent equation- +conormal point with pure first fibre residue. -/ +theorem exists_conormalAxis_of_completedProjectiveBoundaryChartOver + [CharZero K] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChartOver (k := k) (K := K) m hm I) : + ∃ (y : Fin m → LaurentSeries K) + (xi : Fin m → PowerSeries K), + Sum.elim y + (fun i ↦ algebraMap (PowerSeries K) (LaurentSeries K) (xi i)) ∈ + groundEquationConormalLocus (k := k) (K := K) I ∧ + residueColumn xi = + (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + classical + let Iext := I.map (groundPolynomialMap (k := k) (K := K) (Fin m)) + have hbase : ∀ f ∈ Iext, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn W.q)) f = 0 := by + intro f hf + exact eval_eq_zero_of_mem_dehomogenizedEquationIdeal + W.equations W.degree W.homogeneous (laurentColumn W.q) + (laurentColumn_ne_zero_of_ne_zero W.q W.q_origin_ne) + W.equations_vanish f (W.ideal_containment hf) + have htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn W.q)) Iext ≤ + dehomogenizedTangentSpan (laurentColumn W.q) + (laurentNonpositionTangentMatrix W.Z W.tau) := by + exact W.tangent_inclusion + have hphase := + laurentPhasePoint_mem_equationConormalLocus_of_zariski_le_span + Iext W.q W.ell W.Z W.tau W.q_origin_ne W.annihilation hbase htangent + refine ⟨dehomogenizedPoint (laurentColumn W.q), + (fun i : Fin m ↦ W.ell i.succ), ?_, ?_⟩ + · simpa [Iext, groundEquationConormalLocus, laurentColumn] using hphase + · calc + residueColumn (fun i : Fin m ↦ W.ell i.succ) = + (fun i : Fin m ↦ residueColumn W.ell i.succ) := + residueColumn_tail W.ell + _ = (fun i : Fin m ↦ axisRow (k := K) W.axis i.succ) := by + rw [W.residue_axis] + _ = (fun i : Fin m ↦ if i = ⟨0, hm⟩ then 1 else 0) := by + funext i + rw [W.axis_is_first_fibre] + by_cases hi : i = ⟨0, hm⟩ + · subst i + simp [axisRow] + · have hne : i.succ ≠ Fin.succ ⟨0, hm⟩ := by + intro h + exact hi (Fin.succ_injective m h) + change (if i.succ = Fin.succ ⟨0, hm⟩ then 1 else 0) = + (if i = ⟨0, hm⟩ then 1 else 0) + rw [if_neg hne, if_neg hi] + + +end + +end Stafford38.Geometry.LaurentConormalResidueExtension diff --git a/LeanPool/Stafford38/Stafford38/Geometry/LocalizedProjectiveChartTransition.lean b/LeanPool/Stafford38/Stafford38/Geometry/LocalizedProjectiveChartTransition.lean new file mode 100644 index 0000000000..c8eec84ab8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/LocalizedProjectiveChartTransition.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ChartArcAnnihilation +import Mathlib.RingTheory.Localization.Away.Basic + +/-! +# Localized transition between projective affine charts + +The coordinate ring of the overlap between the zeroth affine chart and a +chosen chart is obtained by inverting the chosen-chart coordinate representing +`X₀ / X_chart`. This file constructs the resulting transition homomorphism. +-/ + +namespace Stafford38.Geometry.LocalizedProjectiveChartTransition + +open Stafford38.Geometry.AsymptoticChartArcAdapter +open Stafford38.Geometry.ChartArcAnnihilation +open Stafford38.Geometry.ProjectiveEquationFormalChart + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +/-! ## Zeroth-chart homogenization -/ + +/-- Homogenize an affine polynomial in the zeroth projective coordinate by +padding each homogeneous component to the total degree of the polynomial. -/ +def homogenizeAtZero {m : ℕ} (f : MvPolynomial (Fin m) K) : + MvPolynomial (Fin (m + 1)) K := + ∑ i ∈ Finset.range (f.totalDegree + 1), + MvPolynomial.X 0 ^ (f.totalDegree - i) * + MvPolynomial.rename Fin.succ (MvPolynomial.homogeneousComponent i f) + +/-- The explicit homogenization is homogeneous of the expected degree. -/ +theorem homogenizeAtZero_isHomogeneous {m : ℕ} + (f : MvPolynomial (Fin m) K) : + (homogenizeAtZero f).IsHomogeneous f.totalDegree := by + apply MvPolynomial.IsHomogeneous.sum + intro i hi + have hi_le : i ≤ f.totalDegree := Nat.le_of_lt_succ (Finset.mem_range.mp hi) + have hpow := MvPolynomial.isHomogeneous_X_pow + (R := K) (0 : Fin (m + 1)) (f.totalDegree - i) + have hcomponent := + (MvPolynomial.homogeneousComponent_isHomogeneous i f).rename_isHomogeneous + (f := Fin.succ) + convert hpow.mul hcomponent using 1 + omega + +/-- Dehomogenizing the constructed projective polynomial in chart zero +recovers the original affine polynomial exactly. -/ +theorem projectiveDehomogenize_homogenizeAtZero {m : ℕ} + (f : MvPolynomial (Fin m) K) : + Stafford38.Geometry.ProjectiveEquationFormalChart.projectiveDehomogenize + (homogenizeAtZero f) = f := by + rw [homogenizeAtZero] + simp only [map_sum, map_mul, map_pow] + have hcomponent : ∀ i, + projectiveDehomogenize + (MvPolynomial.rename Fin.succ + (MvPolynomial.homogeneousComponent i f)) = + MvPolynomial.homogeneousComponent i f := by + intro i + rw [show projectiveDehomogenize + (MvPolynomial.rename Fin.succ (MvPolynomial.homogeneousComponent i f)) = + MvPolynomial.bind₁ (Fin.cases 1 fun j ↦ MvPolynomial.X j) + (MvPolynomial.rename Fin.succ + (MvPolynomial.homogeneousComponent i f)) by rfl] + rw [MvPolynomial.bind₁_rename] + have hfun : + ((fun a : Fin (m + 1) ↦ + Fin.cases 1 (fun j ↦ MvPolynomial.X (R := K) j) a) ∘ + Fin.succ) = MvPolynomial.X (R := K) := by + funext j + simp + rw [hfun, MvPolynomial.bind₁_X_left] + rfl + simp_rw [hcomponent] + simp [projectiveDehomogenize] + exact MvPolynomial.sum_homogeneousComponent f + +/-- Every affine ideal over a field has a finite homogeneous projective +equation family whose zeroth-chart dehomogenized ideal is exactly the given +ideal. This is the algebraic homogenization step; it does not assert that the +resulting homogeneous ideal is saturated. -/ +theorem exists_finite_homogeneous_equations_dehomogenizing_to + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) K)) : + ∃ (n : ℕ) (equations : Fin n → MvPolynomial (Fin (m + 1)) K) + (degree : Fin n → ℕ), + (∀ j, (equations j).IsHomogeneous (degree j)) ∧ + dehomogenizedEquationIdeal equations = I := by + obtain ⟨n, generators, hgenerators⟩ := + Submodule.fg_iff_exists_fin_generating_family.mp + (IsNoetherian.noetherian (I : Submodule _ _)) + refine ⟨n, fun j ↦ homogenizeAtZero (generators j), + fun j ↦ (generators j).totalDegree, ?_, ?_⟩ + · intro j + exact homogenizeAtZero_isHomogeneous (generators j) + · rw [dehomogenizedEquationIdeal] + simp_rw [projectiveDehomogenize_homogenizeAtZero] + change Submodule.span _ (Set.range generators) = (I : Submodule _ _) + exact hgenerators + +/-- The projective coordinate `X_a/X_chart`, represented in the polynomial +coordinate ring of the chosen affine chart. -/ +def chartProjectiveCoordinate {m : ℕ} (chart a : Fin (m + 1)) : + MvPolynomial (Fin m) K := + if h : a = chart then 1 + else MvPolynomial.X ((chartAffineCoordinateEquiv chart).symm ⟨a, h⟩) + +/-- The chosen-chart polynomial representing `X₀/X_chart`. -/ +def chartOverlapDenominator {m : ℕ} (chart : Fin (m + 1)) : + MvPolynomial (Fin m) K := + chartProjectiveCoordinate chart 0 + +/-- Coordinate ring of the overlap of the zeroth and chosen projective +affine charts. -/ +abbrev ChartOverlapRing {m : ℕ} (chart : Fin (m + 1)) := + Localization.Away (chartOverlapDenominator (K := K) chart) + +/-- The regular chart transition on the overlap. The old zeroth-chart +coordinate `X_(i+1)/X₀` becomes +`(X_(i+1)/X_chart) / (X₀/X_chart)`. -/ +def chartZeroToChosenOverlap {m : ℕ} (chart : Fin (m + 1)) : + MvPolynomial (Fin m) K →+* ChartOverlapRing (K := K) chart := + MvPolynomial.eval₂Hom + (algebraMap K (ChartOverlapRing (K := K) chart)) + (fun i ↦ + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartProjectiveCoordinate chart i.succ) * + IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart)) + +theorem chartZeroToChosenOverlap_X {m : ℕ} (chart : Fin (m + 1)) + (i : Fin m) : + chartZeroToChosenOverlap (K := K) chart (MvPolynomial.X i) = + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartProjectiveCoordinate chart i.succ) * + IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) := by + simp [chartZeroToChosenOverlap] + +theorem chartOverlapDenominator_mul_invSelf {m : ℕ} + (chart : Fin (m + 1)) : + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartOverlapDenominator (K := K) chart) * + IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) = 1 := by + exact IsLocalization.Away.mul_invSelf _ + +/-! ## Homogeneous scaling without division -/ + +/-- If `s * r = 1`, scaling every coordinate by `r` scales a homogeneous +polynomial of degree `d` by `s⁻ᵈ` in the cancellation-free form displayed +below. This version works in the overlap localization, which need not be a +field. -/ +theorem eval_eq_pow_mul_eval_mul_of_homogeneous + {R : Type*} [CommRing R] {n : ℕ} + (p : MvPolynomial (Fin n) R) (d : ℕ) + (hp : p.IsHomogeneous d) (q : Fin n → R) (s r : R) + (hsr : s * r = 1) : + MvPolynomial.eval q p = + s ^ d * MvPolynomial.eval (fun i ↦ r * q i) p := by + change p.eval₂ (RingHom.id R) q = + s ^ d * p.eval₂ (RingHom.id R) (fun i ↦ r * q i) + rw [MvPolynomial.eval₂_eq', MvPolynomial.eval₂_eq'] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro exponent hexponent + have hdegree : ∑ i, exponent i = d := by + have hweight := hp (MvPolynomial.mem_support_iff.mp hexponent) + rw [Finsupp.weight_apply, + Finsupp.sum_fintype exponent + (fun i c ↦ c • (1 : Fin n → ℕ) i) (by simp)] at hweight + simpa only [Pi.one_apply, smul_eq_mul, mul_one] using hweight + have hcoordinate : ∀ i : Fin n, s * (r * q i) = q i := by + intro i + rw [← mul_assoc, hsr, one_mul] + have hproduct : (∏ i : Fin n, q i ^ exponent i) = + s ^ d * ∏ i : Fin n, (r * q i) ^ exponent i := by + calc + (∏ i : Fin n, q i ^ exponent i) = + ∏ i : Fin n, (s * (r * q i)) ^ exponent i := by + simp_rw [hcoordinate] + _ = (∏ i : Fin n, s ^ exponent i) * + ∏ i : Fin n, (r * q i) ^ exponent i := by + simp_rw [mul_pow] + rw [Finset.prod_mul_distrib] + _ = s ^ d * ∏ i : Fin n, (r * q i) ^ exponent i := by + rw [Finset.prod_pow_eq_pow_sum, hdegree] + rw [hproduct] + ring + +/-! ## The localized chart-overlap identity -/ + +/-- Mapping chosen-chart dehomogenization into the overlap ring is the same +as evaluating the projective polynomial at its chosen-chart coordinates. -/ +theorem algebraMap_projectiveDehomogenizeAt {m : ℕ} + (chart : Fin (m + 1)) (p : MvPolynomial (Fin (m + 1)) K) : + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart p) = + MvPolynomial.eval₂ + (algebraMap K (ChartOverlapRing (K := K) chart)) + (fun a ↦ algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartProjectiveCoordinate chart a)) p := by + rw [show projectiveDehomogenizeAt chart p = + MvPolynomial.bind₁ (chartProjectiveCoordinate (K := K) chart) p by rfl] + rw [MvPolynomial.hom_bind₁] + change MvPolynomial.eval₂ _ _ p = MvPolynomial.eval₂ _ _ p + apply MvPolynomial.eval₂_congr + intro _ _ _ _ + rfl + +/-- Zeroth-chart dehomogenization followed by the overlap transition is +projective evaluation after dividing every chosen-chart coordinate by +`X₀/X_chart`. -/ +theorem chartZeroToChosenOverlap_projectiveDehomogenize {m : ℕ} + (chart : Fin (m + 1)) (p : MvPolynomial (Fin (m + 1)) K) : + chartZeroToChosenOverlap (K := K) chart (projectiveDehomogenize p) = + MvPolynomial.eval₂ + (algebraMap K (ChartOverlapRing (K := K) chart)) + (fun a ↦ + IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) * + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartProjectiveCoordinate chart a)) p := by + rw [show projectiveDehomogenize p = MvPolynomial.bind₁ + (Fin.cases 1 fun i ↦ MvPolynomial.X i) p by rfl] + rw [MvPolynomial.hom_bind₁] + have hcoeff : + (chartZeroToChosenOverlap (K := K) chart).comp MvPolynomial.C = + algebraMap K (ChartOverlapRing (K := K) chart) := by + ext k + simp [chartZeroToChosenOverlap] + rw [hcoeff] + apply MvPolynomial.eval₂_congr + intro a _ _ _ + refine Fin.cases ?_ (fun i ↦ ?_) a + · rw [Fin.cases_zero, map_one] + calc + 1 = algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartOverlapDenominator (K := K) chart) * + IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) := + (chartOverlapDenominator_mul_invSelf (K := K) chart).symm + _ = IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) * + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartProjectiveCoordinate chart 0) := mul_comm _ _ + · rw [Fin.cases_succ, chartZeroToChosenOverlap_X] + exact mul_comm _ _ + +/-- Exact overlap transition for a homogeneous projective equation. The two +dehomogenizations differ by the invertible degree-`d` power of +`X₀/X_chart`; hence they define the same localized equation ideal. -/ +theorem localized_projectiveDehomogenizeAt_eq_pow_mul_transition + {m : ℕ} (chart : Fin (m + 1)) + (p : MvPolynomial (Fin (m + 1)) K) (d : ℕ) + (hp : p.IsHomogeneous d) : + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart p) = + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartOverlapDenominator (K := K) chart) ^ d * + chartZeroToChosenOverlap (K := K) chart + (projectiveDehomogenize p) := by + let L := ChartOverlapRing (K := K) chart + let q : Fin (m + 1) → L := fun a ↦ + algebraMap (MvPolynomial (Fin m) K) L + (chartProjectiveCoordinate chart a) + let s : L := algebraMap (MvPolynomial (Fin m) K) L + (chartOverlapDenominator (K := K) chart) + let r : L := IsLocalization.Away.invSelf + (chartOverlapDenominator (K := K) chart) + have hsr : s * r = 1 := + chartOverlapDenominator_mul_invSelf (K := K) chart + have hscale := eval_eq_pow_mul_eval_mul_of_homogeneous + (MvPolynomial.map (algebraMap K L) p) d + (hp.map (algebraMap K L)) q s r hsr + rw [algebraMap_projectiveDehomogenizeAt] + rw [chartZeroToChosenOverlap_projectiveDehomogenize] + simpa [MvPolynomial.eval_map, q, s, r] using hscale + +/-- Homogenization followed by arbitrary-chart dehomogenization is the +localized transition of the original affine polynomial, up to the expected +invertible power of `X₀/X_chart`. -/ +theorem localized_dehomogenizeAt_homogenizeAtZero + {m : ℕ} (chart : Fin (m + 1)) + (f : MvPolynomial (Fin m) K) : + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart (homogenizeAtZero f)) = + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartOverlapDenominator (K := K) chart) ^ f.totalDegree * + chartZeroToChosenOverlap (K := K) chart f := by + rw [localized_projectiveDehomogenizeAt_eq_pow_mul_transition + chart (homogenizeAtZero f) f.totalDegree + (homogenizeAtZero_isHomogeneous f)] + rw [projectiveDehomogenize_homogenizeAtZero] + +/-- The zeroth-chart equations transported to the overlap ring. -/ +def localizedZeroChartEquationIdeal {m : ℕ} {ι : Type*} + (chart : Fin (m + 1)) + (equations : ι → MvPolynomial (Fin (m + 1)) K) : + Ideal (ChartOverlapRing (K := K) chart) := + Ideal.span (Set.range fun j ↦ + chartZeroToChosenOverlap (K := K) chart + (projectiveDehomogenize (equations j))) + +/-- The chosen-chart equations mapped to the same overlap ring. -/ +def localizedChosenChartEquationIdeal {m : ℕ} {ι : Type*} + (chart : Fin (m + 1)) + (equations : ι → MvPolynomial (Fin (m + 1)) K) : + Ideal (ChartOverlapRing (K := K) chart) := + Ideal.span (Set.range fun j ↦ + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart (equations j))) + +/-- Homogeneous projective equations generate the same ideal after both +affine charts are restricted to their overlap. This is the corrected ideal +statement: equality holds after the chart-transition map and localization, +not between the two untransformed affine polynomial ideals. -/ +theorem localized_chartEquationIdeals_eq + {m : ℕ} {ι : Type*} (chart : Fin (m + 1)) + (equations : ι → MvPolynomial (Fin (m + 1)) K) + (degree : ι → ℕ) + (homogeneous : ∀ j, (equations j).IsHomogeneous (degree j)) : + localizedZeroChartEquationIdeal chart equations = + localizedChosenChartEquationIdeal chart equations := by + apply le_antisymm + · apply Ideal.span_le.mpr + rintro _ ⟨j, rfl⟩ + let s : ChartOverlapRing (K := K) chart := + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (chartOverlapDenominator (K := K) chart) + have hchosen : + algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart (equations j)) ∈ + localizedChosenChartEquationIdeal chart equations := + Ideal.subset_span ⟨j, rfl⟩ + have hrelation := + localized_projectiveDehomogenizeAt_eq_pow_mul_transition + chart (equations j) (degree j) (homogeneous j) + have hmultiple : + chartZeroToChosenOverlap (K := K) chart + (projectiveDehomogenize (equations j)) * s ^ degree j ∈ + localizedChosenChartEquationIdeal chart equations := by + rw [mul_comm, ← hrelation] + exact hchosen + have hs : IsUnit (s ^ degree j) := + (IsLocalization.Away.algebraMap_isUnit + (chartOverlapDenominator (K := K) chart)).pow _ + exact (Ideal.mul_unit_mem_iff_mem _ hs).mp hmultiple + · apply Ideal.span_le.mpr + rintro _ ⟨j, rfl⟩ + change algebraMap (MvPolynomial (Fin m) K) + (ChartOverlapRing (K := K) chart) + (projectiveDehomogenizeAt chart (equations j)) ∈ + localizedZeroChartEquationIdeal chart equations + rw [localized_projectiveDehomogenizeAt_eq_pow_mul_transition + chart (equations j) (degree j) (homogeneous j)] + exact Ideal.mul_mem_left _ _ + (Ideal.subset_span ⟨j, rfl⟩) + +/-- Finite homogenized equations for an affine ideal satisfy the corrected +global-to-local statement on every projective chart overlap. -/ +theorem exists_finite_homogeneous_chartOverlapPresentation + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) K)) : + ∃ (n : ℕ) (equations : Fin n → MvPolynomial (Fin (m + 1)) K) + (degree : Fin n → ℕ), + (∀ j, (equations j).IsHomogeneous (degree j)) ∧ + dehomogenizedEquationIdeal equations = I ∧ + ∀ chart : Fin (m + 1), + localizedZeroChartEquationIdeal chart equations = + localizedChosenChartEquationIdeal chart equations := by + obtain ⟨n, equations, degree, homogeneous, hdehom⟩ := + exists_finite_homogeneous_equations_dehomogenizing_to I + refine ⟨n, equations, degree, homogeneous, hdehom, ?_⟩ + intro chart + exact localized_chartEquationIdeals_eq chart equations degree homogeneous + + +end + + +end Stafford38.Geometry.LocalizedProjectiveChartTransition diff --git a/LeanPool/Stafford38/Stafford38/Geometry/NormalizationHeightOne.lean b/LeanPool/Stafford38/Stafford38/Geometry/NormalizationHeightOne.lean new file mode 100644 index 0000000000..db87edc86e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/NormalizationHeightOne.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Normalization finiteness and height-one places + +Lane C's construction needs four standard commutative-algebra facts that the +paper cites by name. None of them should ever become a project axiom, so they +are proved here from Mathlib alone. + +* `finite_normalization_of_fg_domain` is Noether's finiteness theorem: the + integral closure of a finitely generated domain over a characteristic-zero + field, inside its own fraction field, is a finite module. Mathlib has no + declaration for this. `IsIntegralClosure.finite` requires the base to be + integrally closed already, which is exactly the hypothesis a normalization + argument cannot assume; the proof below routes around it by Noether + normalization to a polynomial ring, which *is* integrally closed, and then + descends finiteness along the finite extension. +* `exists_height_one_minimal_prime` produces the zero divisor: in a Noetherian + domain, a nonzero nonunit has a minimal prime of height exactly one. Krull's + principal ideal theorem gives `≤ 1` and nonvanishing gives `≥ 1`. +* `isDiscreteValuationRing_localization_of_height_eq_one` is the DVR criterion. + It carries **no global dimension hypothesis**: the component may have + dimension greater than one, so the usual Dedekind-domain route is unavailable + and the argument goes through the local Krull-dimension bound and the + `IsDiscreteValuationRing` TFAE instead. +* `height_le_height_under_of_isIntegral` and + `height_under_le_height_of_hasGoingDown` compare the height of a prime with + the height of its contraction along an integral extension, which is what + transports a height-one prime of the normalization back to the chart ring. + +All five are candidates for upstream contribution to Mathlib; nothing here is +Stafford-specific. The proofs are kept exactly as machine-verified, including +the `haveI` style option, so that the checked artefact is not perturbed for +cosmetics. +-/ + +namespace Stafford38.Geometry.NormalizationHeightOne + +open scoped nonZeroDivisors + +attribute [local instance] FractionRing.liftAlgebra + + +universe u + +/-- Noether's finiteness theorem for the normalization of a finitely generated +domain over a field of characteristic zero, in abstract `IsIntegralClosure` +form. -/ +theorem finite_normalization_of_fg_domain + (k R : Type u) [Field k] [CharZero k] [CommRing R] [IsDomain R] [Algebra k R] + [Algebra.FiniteType k R] + (C : Type u) [CommRing C] [Algebra R C] [Algebra C (FractionRing R)] + [IsScalarTower R C (FractionRing R)] [IsIntegralClosure C R (FractionRing R)] : + Module.Finite R C := by + classical + obtain ⟨s, g, hinj, hfin⟩ := exists_finite_inj_algHom_of_fg k R + letI : Algebra (MvPolynomial (Fin s) k) R := g.toRingHom.toAlgebra + haveI : Module.Finite (MvPolynomial (Fin s) k) R := hfin + haveI : FaithfulSMul (MvPolynomial (Fin s) k) R := + (faithfulSMul_iff_algebraMap_injective (MvPolynomial (Fin s) k) R).mpr hinj + haveI : Algebra.IsIntegral (MvPolynomial (Fin s) k) R := inferInstance + letI : Algebra (MvPolynomial (Fin s) k) C := + ((algebraMap R C).comp (algebraMap (MvPolynomial (Fin s) k) R)).toAlgebra + haveI hARC : IsScalarTower (MvPolynomial (Fin s) k) R C := + IsScalarTower.of_algebraMap_eq fun _ => rfl + haveI : IsScalarTower (MvPolynomial (Fin s) k) C (FractionRing R) := by + refine IsScalarTower.of_algebraMap_eq fun x => ?_ + rw [IsScalarTower.algebraMap_apply (MvPolynomial (Fin s) k) R (FractionRing R), + IsScalarTower.algebraMap_apply (MvPolynomial (Fin s) k) R C, + IsScalarTower.algebraMap_apply R C (FractionRing R)] + haveI : IsIntegralClosure C (MvPolynomial (Fin s) k) (FractionRing R) := by + refine ⟨IsIntegralClosure.algebraMap_injective C R (FractionRing R), fun {x} => ?_⟩ + constructor + · intro hx + exact IsIntegralClosure.isIntegral_iff.mp + (IsIntegral.tower_top (R := MvPolynomial (Fin s) k) (A := R) hx) + · rintro ⟨y, rfl⟩ + exact isIntegral_trans (R := MvPolynomial (Fin s) k) (A := R) _ + (IsIntegralClosure.isIntegral R (FractionRing R) y).algebraMap + haveI : Module.Finite (MvPolynomial (Fin s) k) C := + IsIntegralClosure.finite (MvPolynomial (Fin s) k) (FractionRing (MvPolynomial (Fin s) k)) + (FractionRing R) C + exact Module.Finite.of_restrictScalars_finite (MvPolynomial (Fin s) k) R C + +/-- A nonzero nonunit of a Noetherian domain has a minimal prime of height +exactly one. This is the zero divisor of the paper construction. -/ +theorem exists_height_one_minimal_prime + {B : Type*} [CommRing B] [IsDomain B] [IsNoetherianRing B] {x : B} + (hx0 : x ≠ 0) (hxu : ¬ IsUnit x) : + ∃ p : Ideal B, p ∈ (Ideal.span {x}).minimalPrimes ∧ p.height = 1 := by + obtain ⟨p, hp⟩ := (Ideal.span {x}).nonempty_minimalPrimes (by simpa using hxu) + have := hp.isPrime + refine ⟨p, hp, le_antisymm + (Ideal.height_le_one_of_isPrincipal_of_mem_minimalPrimes _ _ hp) ?_⟩ + have hne : p ≠ ⊥ := fun e ↦ + hx0 (by simpa [e, Ideal.span_singleton_eq_bot] using hp.1.2) + rw [Order.one_le_iff_ne_zero] + simpa [Ideal.height_eq_zero_iff_eq_bot] using hne + +/-- The localization of a Noetherian integrally closed domain at a height-one +prime is a discrete valuation ring. No global dimension hypothesis is used, so +this applies on a component of dimension greater than one. -/ +theorem isDiscreteValuationRing_localization_of_height_eq_one + {A : Type*} [CommRing A] [IsDomain A] [IsNoetherianRing A] [IsIntegrallyClosed A] + (p : Ideal A) [p.IsPrime] (h : p.height = 1) : + IsDiscreteValuationRing (Localization.AtPrime p) := by + have hpb : p ≠ ⊥ := Ideal.ne_bot_of_height_eq_one h + have : IsLocalRing (Localization.AtPrime p) := IsLocalization.AtPrime.isLocalRing _ p + have : IsNoetherianRing (Localization.AtPrime p) := + IsLocalization.isNoetherianRing p.primeCompl _ ‹_› + have : IsIntegrallyClosed (Localization.AtPrime p) := + isIntegrallyClosed_of_isLocalization _ p.primeCompl p.primeCompl_le_nonZeroDivisors + have hnf : ¬ IsField (Localization.AtPrime p) := IsLocalization.AtPrime.not_isField A hpb _ + have hkd : Ring.KrullDimLE 1 (Localization.AtPrime p) := by + rw [Ring.krullDimLE_iff, + IsLocalization.AtPrime.ringKrullDim_eq_height p (Localization.AtPrime p), h] + norm_num + have h3 : IsIntegrallyClosed (Localization.AtPrime p) ∧ + ∃! P : Ideal (Localization.AtPrime p), P ≠ ⊥ ∧ P.IsPrime := by + refine ⟨‹_›, IsLocalRing.maximalIdeal _, + ⟨IsLocalRing.isField_iff_maximalIdeal_eq.not.mp hnf, inferInstance⟩, ?_⟩ + rintro P ⟨hPb, hPp⟩ + exact IsLocalRing.eq_maximalIdeal (hPp.isMaximal_of_ne_bot hPb) + exact ((IsDiscreteValuationRing.TFAE (Localization.AtPrime p) hnf).out 3 0).mp h3 + +/-- Contraction along an integral extension does not lower height. -/ +theorem height_le_height_under_of_isIntegral + {R A : Type*} [CommRing R] [CommRing A] [Algebra R A] [Algebra.IsIntegral R A] + (P : Ideal A) [P.IsPrime] : P.height ≤ (Ideal.under R P).height := by + have hs : StrictMono (PrimeSpectrum.comap (algebraMap R A)) := fun x y hxy ↦ + Ideal.IsIntegral.comap_lt_comap (I := x.asIdeal) (J := y.asIdeal) hxy + have h := Order.height_le_height_apply_of_strictMono _ hs (⟨P, ‹_›⟩ : PrimeSpectrum A) + rwa [← PrimeSpectrum.height_eq_orderHeight (⟨P, ‹_›⟩ : PrimeSpectrum A), + ← PrimeSpectrum.height_eq_orderHeight + (PrimeSpectrum.comap (algebraMap R A) (⟨P, ‹_›⟩ : PrimeSpectrum A))] at h + + +end Stafford38.Geometry.NormalizationHeightOne diff --git a/LeanPool/Stafford38/Stafford38/Geometry/OneVariableAmbientConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/OneVariableAmbientConormal.lean new file mode 100644 index 0000000000..3df7180e61 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/OneVariableAmbientConormal.lean @@ -0,0 +1,265 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalBaseVariety +import LeanPool.Stafford38.Stafford38.Geometry.OneVariablePrimeConormal +import Mathlib.FieldTheory.Perfect + +/-! +# Ambient rank-one conormal production + +In one base variable, passing from a radical ambient ideal to one of its +prime components loses the direction needed for conormal containment: if +`I ≤ P`, then the equation-conormal space of `I` is contained in that of `P`, +not conversely. This file avoids that invalid transfer. + +Instead, the radical ambient ideal is principal after identifying the +one-variable multivariate polynomial ring with `k[X]`. Its nonzero generator +is squarefree. At every zero, separability therefore makes the derivative +nonzero, so the ambient equation itself spans the unique cotangent direction. +This produces the Laurent conormal axis for the ambient ideal directly. +-/ + +namespace Stafford38.Geometry.OneVariableAmbientConormal + +open Stafford38 +open Stafford38.Characteristic +open Stafford38.Characteristic.CanonicalBaseVariety +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +private def finOnePolynomialEquiv (k : Type u) [Field k] : + MvPolynomial (Fin 1) k ≃ₐ[k] Polynomial k := + (MvPolynomial.renameEquiv k (Equiv.equivPUnit.{1, 1} (Fin 1))).trans + (MvPolynomial.pUnitAlgEquiv.{u, 0} k) + +private theorem finOnePolynomialEquiv_eval + {k : Type u} [Field k] (f : MvPolynomial (Fin 1) k) (y : Fin 1 → k) : + Polynomial.eval (y 0) (finOnePolynomialEquiv k f) = + MvPolynomial.eval y f := by + induction' f using MvPolynomial.induction_on with a p q hp hq p i hp + · simp [finOnePolynomialEquiv] + · simp [hp, hq] + · fin_cases i + simp only [map_mul, MvPolynomial.rename_X, AlgEquiv.trans_apply, + MvPolynomial.renameEquiv_apply, MvPolynomial.uniqueAlgEquiv_apply, + MvPolynomial.eval_mul, Polynomial.eval_mul] + rw [hp] + simp [finOnePolynomialEquiv] + +private theorem finOnePolynomialEquiv_pderiv + {k : Type u} [Field k] (f : MvPolynomial (Fin 1) k) : + finOnePolynomialEquiv k (MvPolynomial.pderiv (0 : Fin 1) f) = + (finOnePolynomialEquiv k f).derivative := by + induction' f using MvPolynomial.induction_on with a p q hp hq p i hp + · simp [finOnePolynomialEquiv] + · simp [hp, hq] + · fin_cases i + simp only [MvPolynomial.pderiv_mul, MvPolynomial.pderiv_X, + Pi.single_apply, if_pos, one_mul, map_add, map_mul, + MvPolynomial.rename_X, AlgEquiv.trans_apply, + MvPolynomial.renameEquiv_apply, MvPolynomial.uniqueAlgEquiv_apply, + Polynomial.derivative_mul, Polynomial.derivative_X] + rw [hp] + simp [finOnePolynomialEquiv] + +/-- A radical ambient ideal in one variable which avoids the origin has, at +each supplied zero, an ambient equation with nonzero differential. The +equation is the pullback of a principal generator after identifying the ring +with `k[X]`. -/ +theorem exists_ambientEquation_differential_ne_zero + {k : Type u} [Field k] [IsAlgClosed k] + (I : Ideal (MvPolynomial (Fin 1) k)) + (hIrad : I.IsRadical) + (y : Fin 1 → k) + (hy : ∀ f ∈ I, MvPolynomial.eval y f = 0) + (havoid : ∀ z : Fin 1 → k, + (∀ f ∈ I, MvPolynomial.eval z f = 0) → z 0 ≠ 0) : + ∃ f ∈ I, differentialAt y f 0 ≠ 0 := by + let e := finOnePolynomialEquiv k + let Q : Ideal (Polynomial k) := I.map e + have hIne : I ≠ ⊥ := by + intro hI + have hzero : ∀ f ∈ I, + MvPolynomial.eval (fun _ : Fin 1 ↦ (0 : k)) f = 0 := by + intro f hf + have hf0 : f = 0 := by + rw [hI] at hf + simpa using hf + simp [hf0] + exact (havoid (fun _ ↦ 0) hzero) rfl + have hQrad : Q.IsRadical := by + have hQeq : Q = I.comap e.symm := by + ext q + constructor + · intro hq + obtain ⟨f, hf, hef⟩ := + (Ideal.mem_map_iff_of_surjective e e.surjective).mp hq + change e.symm q ∈ I + simpa [← hef] using hf + · intro hq + apply (Ideal.mem_map_iff_of_surjective e e.surjective).mpr + exact ⟨e.symm q, hq, by simp⟩ + rw [hQeq] + exact hIrad.comap e.symm + have hQne : Q ≠ ⊥ := by + intro hQ + apply hIne + exact (Ideal.map_eq_bot_iff_of_injective e.injective).mp hQ + let g : Polynomial k := Submodule.IsPrincipal.generator Q + have hgQ : g ∈ Q := Submodule.IsPrincipal.generator_mem Q + have hg0 : g ≠ 0 := by + intro hg + apply hQne + rw [← Ideal.span_singleton_generator Q] + have hgenerator : Submodule.IsPrincipal.generator Q = 0 := by + simpa [g] using hg + rw [hgenerator, Ideal.span_singleton_eq_bot] + have hgrad : IsRadical g := by + rw [isRadical_iff_span_singleton] + have hspan : Ideal.span ({g} : Set (Polynomial k)) = Q := by + simp [g] + rw [hspan] + exact hQrad + have hgsq : Squarefree g := + (isRadical_iff_squarefree_of_ne_zero hg0).mp hgrad + have hgsep : g.Separable := + PerfectField.separable_iff_squarefree.mpr hgsq + let f : MvPolynomial (Fin 1) k := e.symm g + have hfI : f ∈ I := by + have : e.symm g ∈ I := by + obtain ⟨f', hf', hef'⟩ := + (Ideal.mem_map_iff_of_surjective e e.surjective).mp hgQ + simpa [← hef'] using hf' + exact this + have hgeval : Polynomial.eval (y 0) g = 0 := by + rw [show g = e f by simp [f, e]] + exact (finOnePolynomialEquiv_eval f y).trans (hy f hfI) + have hgderiv : Polynomial.eval (y 0) g.derivative ≠ 0 := + hgsep.eval₂_derivative_ne_zero (RingHom.id k) (by simpa using hgeval) + refine ⟨f, hfI, ?_⟩ + change MvPolynomial.eval y (MvPolynomial.pderiv 0 f) ≠ 0 + rw [← finOnePolynomialEquiv_eval (MvPolynomial.pderiv 0 f) y, + finOnePolynomialEquiv_pderiv] + simpa [f, e] using hgderiv + +/-- In rank one, one ambient equation with nonzero differential spans the +entire cotangent line. -/ +theorem pureAxis_mem_affineConormalSpace_of_differential_ne_zero + {k : Type u} [Field k] + (I : Ideal (MvPolynomial (Fin 1) k)) + (y : Fin 1 → k) (f : MvPolynomial (Fin 1) k) + (hf : f ∈ I) (hdf : differentialAt y f 0 ≠ 0) : + coordinateCovector (fun _ : Fin 1 ↦ 1) ∈ affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan] + have hgenerator : differentialCovector y f ∈ equationCovectorSpan y I := by + apply Submodule.subset_span + exact ⟨⟨f, hf⟩, rfl⟩ + have hscaled := (equationCovectorSpan y I).smul_mem (differentialAt y f 0)⁻¹ hgenerator + convert hscaled using 1 + apply LinearMap.ext + intro v + simp [differentialCovector, coordinateCovector, hdf] + +/-- A radical ambient rank-one ideal with a zero and with origin avoidance +produces the exact Laurent conormal axis required by the terminal projected +consumer. No prime-component conormal is transferred to the ambient ideal. -/ +theorem exists_laurentConormalAxis_of_radical_ambient_axis_avoidance + {k : Type u} [Field k] [IsAlgClosed k] + (I : Ideal (MvPolynomial (Fin 1) k)) + (hIrad : I.IsRadical) + (hexists : ∃ y : Fin 1 → k, + ∀ f ∈ I, MvPolynomial.eval y f = 0) + (havoid : ∀ y : Fin 1 → k, + (∀ f ∈ I, MvPolynomial.eval y f = 0) → y 0 ≠ 0) : + ∃ (yL : Fin 1 → LaurentSeries k) + (xi : Fin 1 → PowerSeries k), + Sum.elim yL + (fun j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi j)) ∈ + equationConormalLocus + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin 1))) ∧ + residueColumn xi = (fun _ : Fin 1 ↦ 1) := by + obtain ⟨y, hy⟩ := hexists + obtain ⟨f, hf, hdf⟩ := + exists_ambientEquation_differential_ne_zero I hIrad y hy havoid + let yL : Fin 1 → LaurentSeries k := + fun j ↦ algebraMap k (LaurentSeries k) (y j) + let xi : Fin 1 → PowerSeries k := fun _ ↦ PowerSeries.C 1 + let IL := I.map + (scalarPolynomialMap (k := k) (K := LaurentSeries k) (Fin 1)) + have hyL : ∀ g ∈ IL, MvPolynomial.eval yL g = 0 := by + rw [show (∀ g ∈ IL, MvPolynomial.eval yL g = 0) ↔ + yL ∈ MvPolynomial.zeroLocus (LaurentSeries k) IL by rfl] + rw [mem_zeroLocus_map_iff] + intro g hg + change MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + ((algebraMap k (LaurentSeries k)) ∘ y) g = 0 + rw [← MvPolynomial.eval₂_comp, hy g hg, map_zero] + have hfIL : scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin 1) f ∈ IL := + Ideal.mem_map_of_mem _ hf + have hdfL : differentialAt yL + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin 1) f) 0 ≠ 0 := by + rw [differentialAt_scalarPolynomialMap] + change MvPolynomial.eval₂ (algebraMap k (LaurentSeries k)) + ((algebraMap k (LaurentSeries k)) ∘ y) + (MvPolynomial.pderiv 0 f) ≠ 0 + rw [← MvPolynomial.eval₂_comp] + simpa [differentialAt] using + (algebraMap k (LaurentSeries k)).injective.ne hdf + have haxisL : coordinateCovector (fun _ : Fin 1 ↦ (1 : LaurentSeries k)) ∈ + affineConormalSpace yL IL := + pureAxis_mem_affineConormalSpace_of_differential_ne_zero IL yL _ hfIL hdfL + refine ⟨yL, xi, ?_, ?_⟩ + · refine ⟨hyL, ?_⟩ + simpa [xi] using haxisL + · funext j + simp [xi, residueColumn] + +/-- Canonical rank-one integration. Phase-space axis avoidance and nonempty +support provide exactly the ambient base hypotheses; radicality of the +canonical contracted base ideal then supplies the Laurent conormal axis. -/ +theorem exists_canonical_rankOne_laurentConormalAxis + {k : Type u} [Field k] [IsAlgClosed k] + (I : RightIdeal (PresentedWeyl k 1)) + (hdisjoint : Disjoint + (orderCharacteristicSupport k I) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin 1))} : + Set (SymbolRing k 1)))) + (hsupp : (orderCharacteristicSupport k I).Nonempty) : + ∃ (yL : Fin 1 → LaurentSeries k) + (xi : Fin 1 → PowerSeries k), + Sum.elim yL + (fun j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi j)) ∈ + equationConormalLocus + ((reducedOrderBaseIdeal k I).map + (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin 1))) ∧ + residueColumn xi = (fun _ : Fin 1 ↦ 1) := by + obtain ⟨hexists, havoid⟩ := + exists_baseZero_and_all_coordinate_ne_zero I (0 : Fin 1) hdisjoint hsupp + exact exists_laurentConormalAxis_of_radical_ambient_axis_avoidance + (reducedOrderBaseIdeal k I) + (reducedOrderBaseIdeal_isRadical k I) hexists havoid + + +end + +end Stafford38.Geometry.OneVariableAmbientConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/OneVariablePrimeConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/OneVariablePrimeConormal.lean new file mode 100644 index 0000000000..918171114b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/OneVariablePrimeConormal.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ConstantCoordinateConormal +import Mathlib.RingTheory.PrincipalIdealDomain + +/-! +# One-variable prime components and the conormal axis + +The completed boundary chart is unavailable in one affine variable, but no +boundary argument is needed there. A prime component of the affine line +whose zero set avoids the origin is nonzero. Transporting it to the ordinary +polynomial ring makes it a nonzero prime in a PID, hence a maximal ideal. +Over an algebraically closed field it is therefore the ideal of one point +`c != 0`, and in particular contains `X - c`. + +The final theorem feeds this component equation into the existing +constant-coordinate consumer and produces the exact Laurent conormal axis. +No projective chart, completion, Gabber input, or filtered cancellation is +used here. +-/ + +namespace Stafford38.Geometry.OneVariablePrimeConormal + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ConstantCoordinateConormal +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +/-- The standard identification of a one-variable multivariate polynomial +ring with the ordinary polynomial ring. -/ +private def finOnePolynomialEquiv (k : Type u) [Field k] : + MvPolynomial (Fin 1) k ≃ₐ[k] Polynomial k := + (MvPolynomial.renameEquiv k (Equiv.equivPUnit.{1, 1} (Fin 1))).trans + (MvPolynomial.pUnitAlgEquiv.{u, 0} k) + +/-- A prime component of the affine line whose entire zero set avoids the +origin is maximal. Algebraic closedness is not needed for this PID step. -/ +theorem primeComponent_isMaximal_of_axis_avoidance + {k : Type u} [Field k] + (P : Ideal (MvPolynomial (Fin 1) k)) [P.IsPrime] + (havoid : ∀ y : Fin 1 → k, + (∀ f ∈ P, MvPolynomial.eval y f = 0) → y 0 ≠ 0) : + P.IsMaximal := by + have hPne : P ≠ ⊥ := by + intro hP + have hzero : ∀ f ∈ P, + MvPolynomial.eval (fun _ : Fin 1 ↦ (0 : k)) f = 0 := by + intro f hf + have hf0 : f = 0 := by + rw [hP] at hf + simpa using hf + rw [hf0] + simp + exact (havoid (fun _ ↦ 0) hzero) rfl + let e := finOnePolynomialEquiv k + let Q : Ideal (Polynomial k) := Ideal.map e P + letI : Q.IsPrime := by + dsimp [Q] + infer_instance + have hQne : Q ≠ ⊥ := by + intro hQ + apply hPne + apply (Ideal.map_eq_bot_iff_of_injective e.injective).mp + exact hQ + have hQmax : Q.IsMaximal := IsPrime.to_maximal_ideal hQne + exact (Ideal.isMaximal_map_iff_of_bijective e e.bijective).mp hQmax + +/-- Componentwise one-variable production: axis avoidance forces the prime +component to be the ideal of a nonzero point and supplies its linear +coordinate equation. -/ +theorem exists_coordinate_sub_constant_mem_of_prime_axis_avoidance + {k : Type u} [Field k] [IsAlgClosed k] + (P : Ideal (MvPolynomial (Fin 1) k)) [P.IsPrime] + (havoid : ∀ y : Fin 1 → k, + (∀ f ∈ P, MvPolynomial.eval y f = 0) → y 0 ≠ 0) : + ∃ (c : k) (y : Fin 1 → k), + c ≠ 0 ∧ y 0 = c ∧ + P = MvPolynomial.vanishingIdeal k {y} ∧ + MvPolynomial.X (0 : Fin 1) - MvPolynomial.C c ∈ P := by + have hmax := primeComponent_isMaximal_of_axis_avoidance P havoid + obtain ⟨y, hPy⟩ := + MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton.mp hmax + let c : k := y 0 + have hy : ∀ f ∈ P, MvPolynomial.eval y f = 0 := by + intro f hf + rw [hPy] at hf + exact (MvPolynomial.mem_vanishingIdeal_singleton_iff y f).mp hf + have hc : c ≠ 0 := havoid y hy + have hcoordinate : + MvPolynomial.X (0 : Fin 1) - MvPolynomial.C c ∈ P := by + rw [hPy, MvPolynomial.mem_vanishingIdeal_singleton_iff] + simp [c] + exact ⟨c, y, hc, rfl, hPy, hcoordinate⟩ + +/-- Ambient-to-component form. If `P` is a prime component above `I`, then +avoidance of the coordinate origin by `V(I)` also holds on `V(P)`, so the +linear equation is produced in the component ideal `P`. -/ +theorem exists_coordinate_sub_constant_mem_of_primeComponent + {k : Type u} [Field k] [IsAlgClosed k] + (I P : Ideal (MvPolynomial (Fin 1) k)) [P.IsPrime] + (hIP : I ≤ P) + (havoid : ∀ y : Fin 1 → k, + (∀ f ∈ I, MvPolynomial.eval y f = 0) → y 0 ≠ 0) : + ∃ (c : k) (y : Fin 1 → k), + c ≠ 0 ∧ y 0 = c ∧ + P = MvPolynomial.vanishingIdeal k {y} ∧ + MvPolynomial.X (0 : Fin 1) - MvPolynomial.C c ∈ P := by + apply exists_coordinate_sub_constant_mem_of_prime_axis_avoidance P + intro y hyP + apply havoid y + intro f hf + exact hyP f (hIP hf) + +/-- Direct rank-one replacement for the impossible boundary-chart branch. +The fibre residue is the unique pure coordinate axis. -/ +theorem exists_laurentConormalAxis_of_prime_axis_avoidance + {k : Type u} [Field k] [IsAlgClosed k] + (P : Ideal (MvPolynomial (Fin 1) k)) [P.IsPrime] + (havoid : ∀ y : Fin 1 → k, + (∀ f ∈ P, MvPolynomial.eval y f = 0) → y 0 ≠ 0) : + ∃ (yL : Fin 1 → LaurentSeries k) + (xi : Fin 1 → PowerSeries k), + Sum.elim yL + (fun j ↦ algebraMap (PowerSeries k) (LaurentSeries k) (xi j)) ∈ + equationConormalLocus + (P.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin 1))) ∧ + residueColumn xi = (fun _ : Fin 1 ↦ 1) := by + obtain ⟨c, y, _hc, _hyc, hPy, hcoordinate⟩ := + exists_coordinate_sub_constant_mem_of_prime_axis_avoidance P havoid + have hy : ∀ f ∈ P, MvPolynomial.eval y f = 0 := by + intro f hf + rw [hPy] at hf + exact (MvPolynomial.mem_vanishingIdeal_singleton_iff y f).mp hf + obtain ⟨yL, xi, hphase, hresidue⟩ := + exists_laurentConormalAxis_of_coordinate_sub_constant_mem + P y hy (0 : Fin 1) c hcoordinate + refine ⟨yL, xi, hphase, ?_⟩ + rw [hresidue] + funext j + fin_cases j + simp + + +end + +end Stafford38.Geometry.OneVariablePrimeConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/PointwiseConormalContainment.lean b/LeanPool/Stafford38/Stafford38/Geometry/PointwiseConormalContainment.lean new file mode 100644 index 0000000000..1dc2c294e5 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/PointwiseConormalContainment.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.BaseRelativePoisson +import LeanPool.Stafford38.Stafford38.Characteristic.ZeroSectionContainment + +/-! +# Pointwise conormal containment + +This file packages the finite-linear-combination consequence of the +base-relative Hamiltonian translation theorem. At a fixed base point, every +finite linear combination of differentials of base equations whose lifts lie +in the ideal is a common zero of the ideal in the corresponding fibre. + +The proof forms the same linear combination of the base equations and applies +the existing one-direction translation theorem once. It assumes zero-section +vanishing at the chosen point; it does not prove that hypothesis or any +homogeneity statement. +-/ + +namespace Stafford38.Geometry.PointwiseConormalContainment + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Characteristic.ZeroSectionContainment +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable {k : Type*} [Field k] {n : ℕ} + +/-- A finite linear combination of base equations. -/ +def baseLinearCombination {ι : Type*} [Fintype ι] + (a : ι → k) (f : ι → MvPolynomial (Fin n) k) : + MvPolynomial (Fin n) k := + ∑ j, MvPolynomial.C (a j) * f j + +/-- The phase-space point whose fibre coordinate is the corresponding finite +linear combination of differentials at `y`. -/ +def differentialCombinationPoint {ι : Type*} [Fintype ι] + (y : Fin n → k) (a : ι → k) (f : ι → MvPolynomial (Fin n) k) : + PhaseVar n → k + | Sum.inl i => y i + | Sum.inr i => ∑ j, a j * differentialAt y (f j) i + +/-- Differentiation at a point commutes with the displayed finite linear +combination. -/ +theorem differentialAt_baseLinearCombination {ι : Type*} [Fintype ι] + (y : Fin n → k) (a : ι → k) (f : ι → MvPolynomial (Fin n) k) + (i : Fin n) : + differentialAt y (baseLinearCombination a f) i = + ∑ j, a j * differentialAt y (f j) i := by + classical + simp [baseLinearCombination, differentialAt, MvPolynomial.pderiv_mul] + +/-- With scalar parameter one, translation by the differential of the +combined equation is exactly the point represented by the combined +differentials. -/ +theorem differentialTranslatePoint_baseLinearCombination_one + {ι : Type*} [Fintype ι] + (y : Fin n → k) (a : ι → k) (f : ι → MvPolynomial (Fin n) k) : + differentialTranslatePoint y (baseLinearCombination a f) 1 = + differentialCombinationPoint y a f := by + classical + funext i + rcases i with i | i + · rfl + · simp [differentialTranslatePoint, differentialCombinationPoint, + differentialAt_baseLinearCombination] + +/-- +Pointwise finite-span form of conormal containment. + +If the zero-section point over `y` is a common zero of `J`, and every displayed +base equation lifts into `J`, then the fibre point obtained from any finite +linear combination of their differentials is again a common zero of `J`. +-/ +theorem differentialCombinationPoint_isCommonZero + [CharZero k] {ι : Type*} [Fintype ι] + (J : Ideal (SymbolRing k n)) (hJ : IsBaseRelativePoisson J) + (y : Fin n → k) + (hzero : ∀ g ∈ J, MvPolynomial.eval (zeroSectionPoint y) g = 0) + (f : ι → MvPolynomial (Fin n) k) + (hf : ∀ j, baseLift (f j) ∈ J) + (a : ι → k) : + ∀ g ∈ J, MvPolynomial.eval (differentialCombinationPoint y a f) g = 0 := by + classical + have hcombined : baseLift (baseLinearCombination a f) ∈ J := by + rw [baseLinearCombination, map_sum] + apply Ideal.sum_mem + intro j hj + rw [map_mul] + exact J.mul_mem_left _ (hf j) + intro g hg + rw [← differentialTranslatePoint_baseLinearCombination_one y a f] + exact + zeroSection_stable_under_differential_translation_of_isBaseRelativePoisson + J hJ y hzero (baseLinearCombination a f) hcombined g hg 1 + +/-- Concrete reduced-support form: a point of the actual reduced order +support supplies its zero-section point by order homogeneity, after which the +base-relative Gabber fragment contains every displayed finite differential +span in the same support fibre. -/ +theorem reducedOrderSupport_differentialCombinationPoint_isCommonZero + [CharZero k] {ι : Type*} [Fintype ι] + (I : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson (reducedOrderSupportIdeal k I)) + (y ξ : Fin n → k) + (hpoint : ∀ g ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (Sum.elim y ξ) g = 0) + (f : ι → MvPolynomial (Fin n) k) + (hf : ∀ j, baseLift (f j) ∈ reducedOrderSupportIdeal k I) + (a : ι → k) : + ∀ g ∈ reducedOrderSupportIdeal k I, + MvPolynomial.eval (differentialCombinationPoint y a f) g = 0 := by + exact differentialCombinationPoint_isCommonZero + (reducedOrderSupportIdeal k I) hJ y + (zeroSection_mem_of_mem_reducedOrderSupport_zeroSet k I y ξ hpoint) + f hf a + + +end + +end Stafford38.Geometry.PointwiseConormalContainment diff --git a/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesArcTangency.lean b/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesArcTangency.lean new file mode 100644 index 0000000000..5e43fd4155 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesArcTangency.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization + +/-! +# Tangency of the formal-arc velocity + +If a power-series arc annihilates an affine ideal coefficientwise, its formal +derivative and the residues of arbitrary derivation directions are Zariski +tangent vectors at the constant point. The result is deliberately +independent of any projective closure or normalization: it consumes an actual +power-series arc and produces actual tangent data for the scalar-extended +base ideal. + +The file does not construct the arc or identify its tangent data with a +projective component. Those chart, normalization, frame-independence, and +dimension arguments remain separate geometric obligations. +-/ + +namespace Stafford38.Geometry.PowerSeriesArcTangency + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ContinuousPowerSeriesTangentFrame +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u + +variable {k : Type u} [Field k] + +/-! ## The formal chain rule -/ + +/-- Chain rule for a derivation of a field-valued polynomial evaluation. -/ +theorem derivation_eval₂ + {S : Type*} [CommSemiring S] [Algebra k S] + (D : Derivation k S S) + {m : ℕ} (f : MvPolynomial (Fin m) k) + (q : Fin m → S) : + D (MvPolynomial.eval₂ (algebraMap k S) q f) = + ∑ i, MvPolynomial.eval₂ (algebraMap k S) q + (MvPolynomial.pderiv i f) * D (q i) := by + induction f using MvPolynomial.induction_on with + | C a => simp [PowerSeries.algebraMap_apply] + | add f g hf hg => + simp only [MvPolynomial.eval₂_add, D.map_add, map_add, hf, hg, + Finset.sum_add_distrib, add_mul] + | mul_X f i hf => + simp only [MvPolynomial.eval₂_mul, D.leibniz, smul_eq_mul, hf, + MvPolynomial.pderiv_mul, map_add, add_mul, Finset.sum_add_distrib, + MvPolynomial.eval₂_add, MvPolynomial.eval₂_X, + MvPolynomial.eval₂_zero, MvPolynomial.pderiv_X, + Pi.single_apply] + simp [Finset.mul_sum, Finset.sum_ite_eq', eq_comm, mul_comm, + mul_left_comm, mul_assoc] + have hsecond : + (∑ x : Fin m, + MvPolynomial.eval₂ (algebraMap k S) q f * + (MvPolynomial.eval₂ (algebraMap k S) q + (if i = x then 1 else 0) * D (q x))) = + MvPolynomial.eval₂ (algebraMap k S) q f * D (q i) := by + classical + rw [← Finset.mul_sum] + congr 1 + simpa using + (Finset.sum_eq_single (s := Finset.univ) + (f := fun x : Fin m ↦ + MvPolynomial.eval₂ (algebraMap k S) + q (if i = x then 1 else 0) * D (q x)) i + (by + intro b hb hbi + simp [hbi, Ne.symm hbi]) + (by + intro hi + exact (hi (Finset.mem_univ i)).elim)) + rw [hsecond] + ring + +/-! ## Derivation directions of extended ideal loci -/ + +/-- A derivation of an evaluation point is tangent to the scalar extension of +an ideal that vanishes at that point. This is the coefficient-direction +analogue of the power-series arc theorem below; it is stated for an arbitrary +field extension and an arbitrary derivation, so no chart or completeness +hypothesis is hidden in the result. -/ +theorem derivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + {S : Type*} [Field S] [Algebra k S] + (D : Derivation k S S) + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → S) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k S) q f = 0) : + (fun i ↦ D (q i)) ∈ + zariskiTangentSpace q + (I.map (MvPolynomial.map (algebraMap k S))) := by + rw [zariskiTangentSpace, Submodule.mem_dualCoannihilator] + intro φ hφ + induction hφ using Submodule.span_induction with + | mem f hf => + rcases hf with ⟨g, rfl⟩ + have hmap : + ∀ h : MvPolynomial (Fin m) S, + h ∈ I.map (MvPolynomial.map (algebraMap k S)) → + MvPolynomial.eval q h = 0 ∧ + differentialCovector q h (fun i ↦ D (q i)) = 0 := by + intro h hh + rw [Ideal.map] at hh + induction hh using Submodule.span_induction with + | mem h hh => + rcases hh with ⟨g, hg, rfl⟩ + constructor + · rw [MvPolynomial.eval_map] + exact hq g hg + · have hderiv := derivation_eval₂ D g q + rw [hq g hg] at hderiv + simpa [differentialCovector, differentialAt, + MvPolynomial.pderiv_map, MvPolynomial.eval_map] using + hderiv.symm + | zero => + simp [differentialCovector, differentialAt] + | add h₁ h₂ hh₁ hh₂ ih₁ ih₂ => + constructor + · rw [MvPolynomial.eval_add, ih₁.1, ih₂.1, add_zero] + · have hi := congrArg₂ (· + ·) ih₁.2 ih₂.2 + change ∑ i, MvPolynomial.eval q + (MvPolynomial.pderiv i (h₁ + h₂)) * D (q i) = 0 + simp only [map_add, MvPolynomial.eval_add, add_mul] + rw [Finset.sum_add_distrib] + simpa [differentialCovector, differentialAt] using hi + | smul a h hh ih => + constructor + · simpa [smul_eq_mul, ih.1] + · have ihD : + ∑ i, MvPolynomial.eval q + (MvPolynomial.pderiv i h) * D (q i) = 0 := by + simpa [differentialCovector, differentialAt] using ih.2 + have hprod : + differentialCovector q (a * h) (fun i ↦ D (q i)) = + MvPolynomial.eval q h * + differentialCovector q a (fun i ↦ D (q i)) + + MvPolynomial.eval q a * + differentialCovector q h (fun i ↦ D (q i)) := by + simp only [differentialCovector_apply, differentialAt, + MvPolynomial.pderiv_mul, + MvPolynomial.eval_add, MvPolynomial.eval_mul, add_mul, + Finset.sum_add_distrib] + simp [Finset.mul_sum, Finset.sum_mul, mul_assoc, mul_comm, + mul_left_comm] + rw [show (a • h : MvPolynomial (Fin m) S) = a * h by rfl] + rw [hprod] + simp [ih.1, ih.2] + exact hmap g.1 g.2 |>.2 + | zero => simp + | add φ ψ hφ hψ ihφ ihψ => + simpa [ihφ, ihψ] + | smul a φ hφ ihφ => + simpa [ihφ] + +/-- Constant-term evaluation commutes with evaluating a base-field +polynomial in a power-series point. -/ +theorem constantCoeff_eval₂ + {K : Type u} [Field K] [Algebra k K] + {m : ℕ} (f : MvPolynomial (Fin m) k) + (q : Fin m → PowerSeries K) : + PowerSeries.constantCoeff + (MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f) = + MvPolynomial.eval₂ (algebraMap k K) + (fun i ↦ PowerSeries.constantCoeff (q i)) f := by + induction f using MvPolynomial.induction_on with + | C a => + simp only [MvPolynomial.eval₂_C] + rw [PowerSeries.algebraMap_apply, PowerSeries.constantCoeff_C] + | add f g hf hg => simp [hf, hg] + | mul_X f i hf => simp [hf] + +/-- The residue of an arbitrary derivation direction on an annihilating +power-series arc is tangent to the scalar-extended base ideal. The +derivation need not preserve the coefficient field: the ideal-span argument +handles the coefficient terms because every base equation already vanishes +along the arc. -/ +theorem residueDerivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + {K : Type u} [Field K] [Algebra k K] + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : Derivation k (PowerSeries K) (PowerSeries K)) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) : + (fun i ↦ PowerSeries.constantCoeff (D (q i))) ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) := by + rw [zariskiTangentSpace, Submodule.mem_dualCoannihilator] + intro φ hφ + induction hφ using Submodule.span_induction with + | mem f hf => + rcases hf with ⟨g, rfl⟩ + have hmap : + ∀ h : MvPolynomial (Fin m) K, + h ∈ I.map (MvPolynomial.map (algebraMap k K)) → + MvPolynomial.eval + (fun i ↦ PowerSeries.constantCoeff (q i)) h = 0 ∧ + differentialCovector + (fun i ↦ PowerSeries.constantCoeff (q i)) h + (fun i ↦ PowerSeries.constantCoeff (D (q i))) = 0 := by + intro h hh + rw [Ideal.map] at hh + induction hh using Submodule.span_induction with + | mem h hh => + rcases hh with ⟨g, hg, rfl⟩ + have hzero := congrArg (PowerSeries.constantCoeff) (hq g hg) + rw [constantCoeff_eval₂] at hzero + constructor + · rw [MvPolynomial.eval_map] + exact hzero + · have hderiv := derivation_eval₂ D g q + rw [hq g hg] at hderiv + have hconst := + congrArg (PowerSeries.constantCoeff) hderiv.symm + simpa [differentialCovector, differentialAt, + MvPolynomial.pderiv_map, MvPolynomial.eval_map, + constantCoeff_eval₂] using hconst + | zero => + simp [differentialCovector, differentialAt] + | add h₁ h₂ hh₁ hh₂ ih₁ ih₂ => + constructor + · rw [MvPolynomial.eval_add, ih₁.1, ih₂.1, add_zero] + · have hi := congrArg₂ (· + ·) ih₁.2 ih₂.2 + change ∑ i, MvPolynomial.eval + (fun i ↦ PowerSeries.constantCoeff (q i)) + (MvPolynomial.pderiv i (h₁ + h₂)) * + PowerSeries.constantCoeff (D (q i)) = 0 + simp only [map_add, MvPolynomial.eval_add, add_mul] + rw [Finset.sum_add_distrib] + simpa [differentialCovector, differentialAt] using hi + | smul a h hh ih => + constructor + · simpa [smul_eq_mul, ih.1] + · have hprod : + differentialCovector + (fun i ↦ PowerSeries.constantCoeff (q i)) + (a * h) + (fun i ↦ PowerSeries.constantCoeff (D (q i))) = + MvPolynomial.eval + (fun i ↦ PowerSeries.constantCoeff (q i)) h * + differentialCovector + (fun i ↦ PowerSeries.constantCoeff (q i)) a + (fun i ↦ PowerSeries.constantCoeff (D (q i))) + + MvPolynomial.eval + (fun i ↦ PowerSeries.constantCoeff (q i)) a * + differentialCovector + (fun i ↦ PowerSeries.constantCoeff (q i)) h + (fun i ↦ PowerSeries.constantCoeff (D (q i))) := by + simp only [differentialCovector_apply, differentialAt, + MvPolynomial.pderiv_mul, MvPolynomial.eval_add, + MvPolynomial.eval_mul, add_mul, Finset.sum_add_distrib] + simp [Finset.mul_sum, Finset.sum_mul, mul_assoc, mul_comm, + mul_left_comm] + rw [show (a • h : MvPolynomial (Fin m) K) = a * h by rfl] + rw [hprod] + simp [ih.1, ih.2] + exact hmap g.1 g.2 |>.2 + | zero => simp + | add φ ψ hφ hψ ihφ ihψ => + simpa [ihφ, ihψ] + | smul a φ hφ ihφ => + simpa [ihφ] + +/-- The uniformizer member of the power-series frame is tangent after +residue specialization whenever the arc annihilates the base ideal. -/ +theorem residueFrameVector_uniformizer_mem_zariskiTangentSpace_of_eval₂_eq_zero + {K : Type u} [Field K] [Algebra k K] + {m κ : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : Fin κ → Derivation k K K) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) : + residueFrameVector (k := k) (K := K) q D none ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) := by + have hD := + residueDerivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + (k := k) (K := K) I q + (uniformizerDerivation (k := k) (K := K)) hq + change (fun i ↦ PowerSeries.constantCoeff + (uniformizerDerivation (k := k) (K := K) (q i))) ∈ _ + exact hD + +/-- Every coefficient-field derivation direction of an annihilating +power-series arc is tangent at its constant point to the scalar-extended +base ideal. -/ +theorem residueFrameVector_coefficient_mem_zariskiTangentSpace_of_eval₂_eq_zero + {K : Type u} [Field K] [Algebra k K] + {m κ : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries K) + (D : Fin κ → Derivation k K K) + (hq : ∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k (PowerSeries K)) q f = 0) + (j : Fin κ) : + residueFrameVector (k := k) (K := K) q D (some j) ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) + (I.map (MvPolynomial.map (algebraMap k K))) := by + have hD := + residueDerivationVector_mem_zariskiTangentSpace_of_eval₂_eq_zero + (k := k) (K := K) I q + (coefficientwiseDerivation (D j)) hq + change (fun i ↦ PowerSeries.constantCoeff + (coefficientwiseDerivation (D j) (q i))) ∈ _ + exact hD + +/-- Formal chain rule for evaluating a polynomial along a power-series arc. -/ +theorem derivative_eval_map + {m : ℕ} (f : MvPolynomial (Fin m) k) + (q : Fin m → PowerSeries k) : + PowerSeries.derivative k + (MvPolynomial.eval q (MvPolynomial.map (PowerSeries.C) f)) = + ∑ i, MvPolynomial.eval q + (MvPolynomial.map (PowerSeries.C) (MvPolynomial.pderiv i f)) * + PowerSeries.derivative k (q i) := by + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => + simp only [map_add, MvPolynomial.eval_add, Derivation.map_add, + hf, hg, Finset.sum_add_distrib, add_mul] + | mul_X f i hf => + simp only [map_mul, MvPolynomial.eval_mul, Derivation.leibniz, + smul_eq_mul, map_add, hf, MvPolynomial.pderiv_mul, add_mul, + Finset.sum_add_distrib] + simp [Pi.single_apply, Finset.mul_sum, mul_comm, mul_left_comm, + mul_assoc] + +/-! ## Tangency at the closed point -/ + +/-- The velocity of a power-series arc at its constant term. -/ +def arcVelocity {m : ℕ} (q : Fin m → PowerSeries k) : Fin m → k := + fun i ↦ PowerSeries.constantCoeff (PowerSeries.derivative k (q i)) + +@[simp] +theorem arcVelocity_eq_residueFrameVector + {m κ : ℕ} (q : Fin m → PowerSeries k) + (D : Fin κ → Derivation k k k) : + arcVelocity q = residueFrameVector q D none := + rfl + +/-- The formal-arc velocity annihilates the differential of every polynomial +that vanishes identically along the arc. -/ +theorem differentialCovector_arcVelocity_eq_zero_of_eval_eq_zero + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries k) + (hq : ∀ f ∈ I, + MvPolynomial.eval q (MvPolynomial.map (PowerSeries.C) f) = 0) : + ∀ f ∈ I, + differentialCovector (fun i ↦ PowerSeries.constantCoeff (q i)) f + (arcVelocity q) = 0 := by + intro f hf + have hderiv := derivative_eval_map f q + rw [hq f hf, map_zero] at hderiv + have hconst : + (0 : k) = + ∑ i, PowerSeries.constantCoeff + (MvPolynomial.eval q + (MvPolynomial.map (PowerSeries.C) + (MvPolynomial.pderiv i f))) * + PowerSeries.constantCoeff + (PowerSeries.derivative k (q i)) := by + simpa only [map_zero, map_sum, map_mul] using + congrArg (PowerSeries.constantCoeff) hderiv + simp_rw [residue_eval_map] at hconst + have hres : residueColumn q = + (fun i ↦ PowerSeries.constantCoeff (q i)) := rfl + rw [hres] at hconst + simpa [differentialCovector, differentialAt, arcVelocity, + ← PowerSeries.coeff_zero_eq_constantCoeff, + PowerSeries.coeff_mul, Finset.sum_apply, Finset.sum_mul] using hconst.symm + +/-- An actual power-series arc supplies the uniformizer tangent vector needed +by the higher-dimensional conormal consumer. -/ +theorem arcVelocity_mem_zariskiTangentSpace_of_eval_eq_zero + {m : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries k) + (hq : ∀ f ∈ I, + MvPolynomial.eval q (MvPolynomial.map (PowerSeries.C) f) = 0) : + arcVelocity q ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I := by + rw [zariskiTangentSpace, Submodule.mem_dualCoannihilator] + intro φ hφ + induction hφ using Submodule.span_induction with + | mem f hf => + rcases hf with ⟨g, rfl⟩ + exact differentialCovector_arcVelocity_eq_zero_of_eval_eq_zero I q hq + g.1 g.2 + | zero => simp + | add φ ψ hφ hψ ihφ ihψ => + simpa [ihφ, ihψ] + | smul a φ hφ ihφ => + simpa [ihφ] + +@[simp] +theorem residueFrameVector_none_mem_zariskiTangentSpace_of_eval_eq_zero + {m κ : ℕ} (I : Ideal (MvPolynomial (Fin m) k)) + (q : Fin m → PowerSeries k) (D : Fin κ → Derivation k k k) + (hq : ∀ f ∈ I, + MvPolynomial.eval q (MvPolynomial.map (PowerSeries.C) f) = 0) : + residueFrameVector q D none ∈ + zariskiTangentSpace + (fun i ↦ PowerSeries.constantCoeff (q i)) I := by + rw [← arcVelocity_eq_residueFrameVector q D] + exact arcVelocity_mem_zariskiTangentSpace_of_eval_eq_zero I q hq + + +end + +end Stafford38.Geometry.PowerSeriesArcTangency diff --git a/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesTangentLimit.lean b/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesTangentLimit.lean new file mode 100644 index 0000000000..9e3a70e0a3 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/PowerSeriesTangentLimit.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization + +/-! +# A power-series tangent-lattice limit + +This file isolates an elementary power-series calculation used in a +Grassmannian limit. A matrix `T` of tangent columns is presented as `X ^ m` +times a matrix `B`. If one selected coordinate of every column of `T` has a +specified additional positive power of `X`, then the selected row of `B` +vanishes in the residue field. Consequently the corresponding coordinate +covector annihilates the residue of `B`. + +If, as a separate hypothesis, the columns of `B` are split, the retraction +correction from `RetractionSpecialization` lifts that residue row to an exact +annihilator over `k[[X]]`. This is only the tangent-lattice calculation. It +does not construct the split lattice from `T`, nor does it construct an arc, a +normalization, a divisor at infinity, or a projective closure. +-/ + +namespace Stafford38.GeometryPowerSeriesTangentLimit + +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u v + +variable {k : Type u} [Field k] + +/-- The coordinate row selecting `axis`. -/ +def axisRow {ι : Type*} [DecidableEq ι] (axis : ι) : ι → k := + fun i => if i = axis then 1 else 0 + +@[simp] theorem axisRow_apply_same {ι : Type*} [DecidableEq ι] (axis : ι) : + axisRow (k := k) axis axis = 1 := by + simp [axisRow] + +@[simp] theorem axisRow_apply_of_ne {ι : Type*} [DecidableEq ι] + {axis i : ι} (hi : i ≠ axis) : axisRow (k := k) axis i = 0 := by + simp [axisRow, hi] + +/-- `T` is presented as the common power `X ^ m` times `B`. + +No maximality of `m` and no splitting of `B` is asserted here. +-/ +def HasCommonPowerPresentation {ι κ : Type*} + (T B : Matrix ι κ (PowerSeries k)) (m : ℕ) : Prop := + ∀ i j, T i j = (PowerSeries.X : PowerSeries k) ^ m * B i j + +/-- The selected coordinate has order at least `m + gap + 1` in every column. -/ +def HasSelectedOrderGap {ι κ : Type*} + (T : Matrix ι κ (PowerSeries k)) (axis : ι) (m gap : ℕ) : Prop := + ∀ j, ∃ u : PowerSeries k, + T axis j = (PowerSeries.X : PowerSeries k) ^ (m + (gap + 1)) * u + +/-- +Cancelling the common factor shows that the selected row of the normalized +matrix still contains a positive power of `X`. +-/ +theorem normalized_selectedRow_factor + {ι κ : Type*} (T B : Matrix ι κ (PowerSeries k)) + (axis : ι) (m gap : ℕ) + (hnorm : HasCommonPowerPresentation T B m) + (hgap : HasSelectedOrderGap T axis m gap) : + ∀ j, ∃ u : PowerSeries k, + B axis j = (PowerSeries.X : PowerSeries k) ^ (gap + 1) * u := by + intro j + obtain ⟨u, hu⟩ := hgap j + refine ⟨u, ?_⟩ + have hpow : + (PowerSeries.X : PowerSeries k) ^ m * B axis j = + (PowerSeries.X : PowerSeries k) ^ m * + ((PowerSeries.X : PowerSeries k) ^ (gap + 1) * u) := by + rw [← hnorm axis j, hu, pow_add, mul_assoc] + exact mul_left_cancel₀ (pow_ne_zero m PowerSeries.X_ne_zero) hpow + +/-- The strict order gap makes the selected normalized row vanish modulo `X`. -/ +theorem residue_normalized_selectedRow_eq_zero + {ι κ : Type*} (T B : Matrix ι κ (PowerSeries k)) + (axis : ι) (m gap : ℕ) + (hnorm : HasCommonPowerPresentation T B m) + (hgap : HasSelectedOrderGap T axis m gap) : + ∀ j, PowerSeries.constantCoeff (B axis j) = 0 := by + intro j + obtain ⟨u, hu⟩ := normalized_selectedRow_factor T B axis m gap hnorm hgap j + rw [hu] + simp [pow_succ] + +/-- The selected coordinate covector annihilates the residue tangent columns. -/ +theorem axisRow_residue_rowMul_eq_zero + {ι κ : Type*} [Fintype ι] [DecidableEq ι] + (T B : Matrix ι κ (PowerSeries k)) + (axis : ι) (m gap : ℕ) + (hnorm : HasCommonPowerPresentation T B m) + (hgap : HasSelectedOrderGap T axis m gap) : + rowMul (axisRow (k := k) axis) + (fun i j => PowerSeries.constantCoeff (B i j)) = 0 := by + funext j + simp [rowMul, axisRow, + residue_normalized_selectedRow_eq_zero T B axis m gap hnorm hgap j] + +/-- +Tangent-lattice limit with a split power-series column matrix. + +The returned row annihilates `B` exactly over `k[[X]]` and specializes to the +selected coordinate covector. Thus that residue covector is represented by a +genuine power-series annihilator, not merely by a row annihilating the special +fibre. The left inverse `C` is an independent lattice-splitting hypothesis; +it is not obtained from the common-power presentation. +-/ +theorem exists_annihilator_specializing_to_axis + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (T B : Matrix ι κ (PowerSeries k)) + (C : Matrix κ ι (PowerSeries k)) + (axis : ι) (m gap : ℕ) + (hnorm : HasCommonPowerPresentation T B m) + (hgap : HasSelectedOrderGap T axis m gap) + (hCB : C * B = 1) : + ∃ a : ι → PowerSeries k, + rowMul a B = 0 ∧ residueColumn a = axisRow (k := k) axis := by + let a₀ : ι → k := axisRow (k := k) axis + let a : ι → PowerSeries k := + annihilatorLift (constantColumn a₀) B C + refine ⟨a, ?_⟩ + have hres : residueColumn (constantColumn a₀) = a₀ := + residueColumn_constantColumn a₀ + have haxis : + rowMul a₀ (fun i j => PowerSeries.constantCoeff (B i j)) = 0 := + axisRow_residue_rowMul_eq_zero T B axis m gap hnorm hgap + simpa [a, a₀] using + (powerSeries_annihilatorLift_spec (constantColumn a₀) a₀ B C hCB hres haxis) + + +end + +end Stafford38.GeometryPowerSeriesTangentLimit diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveBoundaryFrameRank.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveBoundaryFrameRank.lean new file mode 100644 index 0000000000..74057baf14 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveBoundaryFrameRank.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalAsymptoticLaurentProducer + +/-! +# Projective residue frames and the generic tangent rank bound + +This file extracts two consequences which are already forced by the completed +projective/DVR certificate but were previously left as consumer hypotheses. + +First, full column rank of an augmented projective matrix `[q | B]` implies +linear independence of the affine columns obtained by differentiating in any +chart where `q` is nonzero. The chart is arbitrary: the completed certificate +does not identify its normalized chart coordinate with coordinate zero. + +Second, the stored Laurent tangent inclusion bounds the generic tangent +dimension by the number of nonposition columns, namely `tangentCount + 1`. +This is a generic-fibre statement. No equality with an arc-derivation frame +and no closed-boundary tangent bound is asserted; either conclusion needs an +additional geometric comparison. +-/ + +namespace Stafford38.Geometry.ProjectiveBoundaryFrameRank + +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CanonicalAsymptoticLaurentProducer +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryResidueMinorSelection + +noncomputable section + +universe u v w + +variable {K : Type u} [Field K] + +/-- Coordinates remaining after choosing an arbitrary projective chart. -/ +abbrev ChartAffineIndex (ι : Type v) (chart : ι) := {i : ι // i ≠ chart} + +/-- Differential of `q_i / q_chart` in the projective direction `w`. -/ +def chartDehomogenizedTangentColumn {ι : Type v} (chart : ι) + (q w : ι → K) : ChartAffineIndex ι chart → K := + fun i ↦ (w i.1 * q chart - q i.1 * w chart) / q chart ^ 2 + +/-- Adjoin the projective position column to a family of tangent columns. -/ +def augmentedProjectiveMatrix {ι : Type v} {κ : Type w} + (q : ι → K) (B : Matrix ι κ K) : Matrix ι (Unit ⊕ κ) K + | i, Sum.inl _ => q i + | i, Sum.inr j => B i j + +/-- The nonposition part of the formal power-series tangent matrix. -/ +def nonpositionPowerSeriesMatrix {k : Type u} {ι : Type v} {κ : Type w} + [Field k] (Z : Matrix ι κ (PowerSeries k)) + (tau : ι → PowerSeries k) : Matrix ι (κ ⊕ Unit) (PowerSeries k) + | i, Sum.inl j => Z i j + | i, Sum.inr _ => tau i + +/-- Independent projective position and tangent columns remain independent +after passing to affine tangent vectors in any nonvanishing chart. -/ +theorem linearIndependent_chartDehomogenizedTangentColumns + {ι : Type v} {κ : Type w} [Fintype κ] + (chart : ι) (q : ι → K) (B : Matrix ι κ K) + (hq : q chart ≠ 0) + (hinjective : Function.Injective (augmentedProjectiveMatrix q B).mulVec) : + LinearIndependent K + (fun j ↦ chartDehomogenizedTangentColumn chart q (fun i ↦ B i j)) := by + classical + apply Fintype.linearIndependent_iff.mpr + intro c hc j + let s : K := -(∑ a, c a * B chart a) / q chart + let c' : Unit ⊕ κ → K + | Sum.inl _ => s + | Sum.inr a => c a + have hc' : (augmentedProjectiveMatrix q B).mulVec c' = 0 := by + funext i + simp only [Pi.zero_apply, Matrix.mulVec, dotProduct, + augmentedProjectiveMatrix, c', Fintype.sum_sum_type, + Fintype.sum_unique, one_mul] + change q i * s + ∑ a, B i a * c a = 0 + by_cases hi : i = chart + · subst i + rw [show s = -(∑ a, c a * B chart a) / q chart by rfl, + mul_div_cancel₀ _ hq] + simp [mul_comm] + · have hcoordinate := congrFun hc ⟨i, hi⟩ + simp only [Pi.zero_apply] at hcoordinate + simp [chartDehomogenizedTangentColumn] at hcoordinate + simp_rw [← mul_div_assoc] at hcoordinate + rw [← Finset.sum_div] at hcoordinate + simp only [s] + field_simp [hq] at hcoordinate ⊢ + have hcoordinate' : + q chart * (∑ a, B i a * c a) - + q i * (∑ a, B chart a * c a) = 0 := by + simpa [mul_sub, Finset.sum_sub_distrib, Finset.sum_mul, + ← Finset.mul_sum, mul_comm, mul_left_comm, mul_assoc] using hcoordinate + have hchartSum : (∑ a, c a * B chart a) = + ∑ a, B chart a * c a := by + apply Finset.sum_congr rfl + intro a ha + exact mul_comm _ _ + rw [hchartSum] + linear_combination hcoordinate' + have hc'_zero : c' = 0 := by + apply hinjective + simpa using hc' + exact congrFun hc'_zero (Sum.inr j) + +/-- Entrywise reduction of a power-series left inverse remains a left inverse +of the residue matrix. -/ +theorem residueMatrix_mul_eq_one_of_mul_eq_one + {k : Type u} [Field k] {ι : Type v} {κ : Type w} + [Fintype ι] [Fintype κ] [DecidableEq κ] + (C : Matrix κ ι (PowerSeries k)) (B : Matrix ι κ (PowerSeries k)) + (hCB : C * B = 1) : + residueMatrix C * residueMatrix B = 1 := by + ext i j + have hij := congrArg (PowerSeries.constantCoeff) + (congrFun (congrFun hCB i) j) + simpa [Matrix.mul_apply, Matrix.one_apply, residueMatrix, map_sum] using hij + +/-- A power-series left inverse therefore gives full column rank after +reduction modulo the uniformizer. -/ +theorem residueMatrix_mulVec_injective_of_leftInverse + {k : Type u} [Field k] {ι : Type v} {κ : Type w} + [Fintype ι] [Fintype κ] [DecidableEq κ] + (C : Matrix κ ι (PowerSeries k)) (B : Matrix ι κ (PowerSeries k)) + (hCB : C * B = 1) : + Function.Injective (residueMatrix B).mulVec := by + intro x y hxy + have h := congrArg (residueMatrix C).mulVec hxy + rw [Matrix.mulVec_mulVec, Matrix.mulVec_mulVec, + residueMatrix_mul_eq_one_of_mul_eq_one C B hCB, + Matrix.one_mulVec] at h + simpa using h + +/-- The completed certificate's split formal matrix produces a genuinely +independent affine residue frame in its normalized projective chart. -/ +theorem completedBoundaryChart_residueFrame_linearIndependent + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) : + LinearIndependent k + (fun j : (Fin W.tangentCount ⊕ Unit) ↦ + chartDehomogenizedTangentColumn W.chart + (fun i ↦ PowerSeries.constantCoeff (W.q i)) + (fun i ↦ PowerSeries.constantCoeff + (nonpositionPowerSeriesMatrix W.Z W.tau i j))) := by + apply linearIndependent_chartDehomogenizedTangentColumns W.chart + · simp [W.q_chart] + · have hinj := residueMatrix_mulVec_injective_of_leftInverse + W.C (formalTangentMatrix W.q W.Z W.tau) W.left_inverse + have hmatrix : + residueMatrix (formalTangentMatrix W.q W.Z W.tau) = + augmentedProjectiveMatrix + (fun i ↦ PowerSeries.constantCoeff (W.q i)) + (fun i j ↦ PowerSeries.constantCoeff + (nonpositionPowerSeriesMatrix W.Z W.tau i j)) := by + ext i j + rcases j with (_ | (j | _)) <;> + rfl + rw [hmatrix] at hinj + exact hinj + +/-- The stored generic tangent inclusion gives the exact numerical bound by +the number of supplied nonposition columns. -/ +theorem completedBoundaryChart_genericTangent_finrank_le + {k : Type u} [Field k] [CharZero k] + {m : ℕ} (hm : 0 < m) + (I : Ideal (MvPolynomial (Fin m) k)) + (W : CompletedProjectiveBoundaryChart k m hm I) : + Module.finrank (LaurentSeries k) + (zariskiTangentSpace (dehomogenizedPoint (laurentColumn W.q)) + (I.map (Stafford38.Geometry.ScalarExtensionPoints.scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)))) ≤ + W.tangentCount + 1 := by + calc + Module.finrank (LaurentSeries k) + (zariskiTangentSpace (dehomogenizedPoint (laurentColumn W.q)) + (I.map (Stafford38.Geometry.ScalarExtensionPoints.scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin m)))) ≤ + Module.finrank (LaurentSeries k) + (dehomogenizedTangentSpan (laurentColumn W.q) + (laurentNonpositionTangentMatrix W.Z W.tau)) := + Submodule.finrank_mono W.tangent_inclusion + _ ≤ Fintype.card (Fin W.tangentCount ⊕ Unit) := + finrank_range_le_card + (fun j ↦ dehomogenizedTangentColumn (laurentColumn W.q) + (fun i ↦ laurentNonpositionTangentMatrix W.Z W.tau i j)) + _ = W.tangentCount + 1 := by simp + + +end + +end Stafford38.Geometry.ProjectiveBoundaryFrameRank diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDehomogenization.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDehomogenization.lean new file mode 100644 index 0000000000..8c9ce65b69 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDehomogenization.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.JacobianConormalComparison +import LeanPool.Stafford38.Stafford38.Geometry.RetractionSpecialization + +/-! +# Dehomogenizing projective conormal data + +This file isolates the field-level calculation that turns a projective point, +projective tangent columns, and a projective annihilating row into affine +conormal data in the chart where the zeroth coordinate is nonzero. + +No projective closure, normalization, formal chart, tangent-space comparison, +Laurent specialization, closure theorem, or coisotropy statement is constructed +here. The tangent-space equality and the base equations are explicit inputs. +-/ + +namespace Stafford38.Geometry.ProjectiveConormalDehomogenization + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.JacobianConormalComparison +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {K : Type*} [Field K] {n : ℕ} + +/-- The affine point represented by `q` in the chart `q 0 ≠ 0`. -/ +def dehomogenizedPoint (q : Fin (n + 1) → K) : Fin n → K := + fun i ↦ q i.succ / q 0 + +/-- The derivative of the affine chart coordinate `q_(i+1) / q_0` in the +projective tangent direction `w`. -/ +def dehomogenizedTangentColumn + (q w : Fin (n + 1) → K) : Fin n → K := + fun i ↦ (w i.succ * q 0 - q i.succ * w 0) / q 0 ^ 2 + +/-- The affine tangent subspace generated by dehomogenizing the supplied +projective tangent columns. -/ +def dehomogenizedTangentSpan {κ : Type*} + (q : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) : + Submodule K (AffineTangentVector K n) := + Submodule.span K + (Set.range fun j ↦ dehomogenizedTangentColumn q (fun i ↦ B i j)) + +/-- A projective row annihilating both the point and every supplied +projective tangent column gives an affine coordinate covector annihilating +the dehomogenized tangent span. -/ +theorem coordinateCovector_mem_dehomogenizedTangentSpan_dualAnnihilator + {κ : Type*} + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) : + coordinateCovector (fun i ↦ ell i.succ) ∈ + (dehomogenizedTangentSpan q B).dualAnnihilator := by + rw [Submodule.mem_dualAnnihilator] + intro v hv + rw [dehomogenizedTangentSpan] at hv + induction hv using Submodule.span_induction with + | mem v hv => + rcases hv with ⟨j, rfl⟩ + have hqTail : ∑ i : Fin n, ell i.succ * q i.succ = -(ell 0 * q 0) := by + rw [Fin.sum_univ_succ] at hq + linear_combination hq + have hBTail : ∑ i : Fin n, ell i.succ * B i.succ j = -(ell 0 * B 0 j) := by + have hj := congrFun hB j + simp only [Pi.zero_apply, rowMul, Fin.sum_univ_succ] at hj + linear_combination hj + simp only [coordinateCovector_apply, dehomogenizedTangentColumn] + simp_rw [← mul_div_assoc] + rw [← Finset.sum_div] + field_simp [hq0] + calc + (∑ i : Fin n, ell i.succ * + (B i.succ j * q 0 - q i.succ * B 0 j)) = + (∑ i : Fin n, (ell i.succ * B i.succ j) * q 0) - + ∑ i : Fin n, (ell i.succ * q i.succ) * B 0 j := by + rw [← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + _ = (∑ i : Fin n, ell i.succ * B i.succ j) * q 0 - + (∑ i : Fin n, ell i.succ * q i.succ) * B 0 j := by + rw [Finset.sum_mul, Finset.sum_mul] + _ = q 0 ^ 2 * 0 := by rw [hBTail, hqTail]; ring + | zero => exact map_zero (coordinateCovector (fun i ↦ ell i.succ)) + | add x y _ _ hx hy => + simpa [hx, hy] using map_add (coordinateCovector (fun i ↦ ell i.succ)) x y + | smul a x _ hx => + simp [map_smul, hx] + +/-- If the dehomogenized column span is the embedded Zariski tangent space, +then the tail of the projective annihilating row is an affine conormal +covector. -/ +theorem coordinateCovector_mem_affineConormalSpace_of_projective_row + {κ : Type*} + (I : Ideal (MvPolynomial (Fin n) K)) + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) + (htangent : + dehomogenizedTangentSpan q B = zariskiTangentSpace (dehomogenizedPoint q) I) : + coordinateCovector (fun i ↦ ell i.succ) ∈ + affineConormalSpace (dehomogenizedPoint q) I := by + rw [affineConormalSpace, ← htangent] + exact coordinateCovector_mem_dehomogenizedTangentSpan_dualAnnihilator + q ell B hq0 hq hB + +/-- Projective point and tangent data produce a point of the equation-defined +affine conormal locus once base-equation membership and the exact Zariski +tangent-space identification are supplied. -/ +theorem phasePoint_mem_equationConormalLocus_of_projective_row + {κ : Type*} + (I : Ideal (MvPolynomial (Fin n) K)) + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) + (hbase : ∀ f ∈ I, MvPolynomial.eval (dehomogenizedPoint q) f = 0) + (htangent : + dehomogenizedTangentSpan q B = zariskiTangentSpace (dehomogenizedPoint q) I) : + Sum.elim (dehomogenizedPoint q) (fun i ↦ ell i.succ) ∈ + equationConormalLocus I := by + refine ⟨?_, ?_⟩ + · simpa using hbase + · simpa using coordinateCovector_mem_affineConormalSpace_of_projective_row + I q ell B hq0 hq hB htangent + +/-- Jacobian-facing form of the same bridge. The supplied equations belong +to `I`, and the dehomogenized column span is identified exactly with their +Jacobian tangent kernel. -/ +theorem phasePoint_mem_equationConormalLocus_of_projective_row_jacobian + {κ ι : Type*} + (I : Ideal (MvPolynomial (Fin n) K)) + (equations : ι → MvPolynomial (Fin n) K) + (hequations : ∀ i, equations i ∈ I) + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) + (hbase : ∀ f ∈ I, MvPolynomial.eval (dehomogenizedPoint q) f = 0) + (htangent : + dehomogenizedTangentSpan q B = + jacobianTangentSpace (dehomogenizedPoint q) equations) : + Sum.elim (dehomogenizedPoint q) (fun i ↦ ell i.succ) ∈ + equationConormalLocus I := by + refine ⟨?_, ?_⟩ + · simpa using hbase + · apply jacobianConormalSpace_le_affineConormalSpace + (dehomogenizedPoint q) I equations hequations + change coordinateCovector (fun i ↦ ell i.succ) ∈ + (jacobianTangentSpace (dehomogenizedPoint q) equations).dualAnnihilator + rw [← htangent] + exact coordinateCovector_mem_dehomogenizedTangentSpan_dualAnnihilator + q ell B hq0 hq hB + + +end + +end Stafford38.Geometry.ProjectiveConormalDehomogenization diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDirections.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDirections.lean new file mode 100644 index 0000000000..ae60d5fc47 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveConormalDirections.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.LinearAlgebra.Projectivization.Basic +import Mathlib.RingTheory.MvPolynomial.Homogeneous +import LeanPool.Stafford38.Stafford38.Geometry.SmoothAffineConormal + +/-! +# Projective conormal directions + +Only the polynomial criterion is recorded here. This file does not identify +an asymptotic conormal variety with a projective closure. +-/ + +namespace Stafford38.Geometry.ProjectiveConormalDirections + +open scoped LinearAlgebra.Projectivization +open Stafford38.Characteristic +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.SmoothAffineConormal + +noncomputable section + +variable {k : Type*} [Field k] [IsAlgClosed k] {n : ℕ} + +def projectiveHomogeneousZeroLocus (P : MvPolynomial (Fin n) k) : + Set (Projectivization k (Fin n → k)) := + {z | ∀ v : Fin n → k, ∀ hv : v ≠ 0, + z = Projectivization.mk k v hv → MvPolynomial.eval v P = 0} + +def projectiveHomogeneousClosure + (T : Set (Projectivization k (Fin n → k))) : + Set (Projectivization k (Fin n → k)) := + {z | ∀ P : MvPolynomial (Fin n) k, ∀ d : ℕ, + P.IsHomogeneous d → + T ⊆ projectiveHomogeneousZeroLocus P → + z ∈ projectiveHomogeneousZeroLocus P} + +def smoothConormalDirectionSet + (I : Ideal (MvPolynomial (Fin n) k)) : + Set (Fin n → k) := + {ξ | ∃ y : Fin n → k, + SmoothAffinePoint I y ∧ ξ ≠ 0 ∧ + coordinateCovector ξ ∈ affineConormalSpace y I} + +def smoothConormalFibreProjection + (I : Ideal (MvPolynomial (Fin n) k)) : Set (Fin n → k) := + {ξ | ∃ y : Fin n → k, + SmoothAffinePoint I y ∧ + coordinateCovector ξ ∈ affineConormalSpace y I} + +def projectivizedDirectionSet (T : Set (Fin n → k)) : + Set (Projectivization k (Fin n → k)) := + {z | ∃ v, v ∈ T ∧ ∃ hv : v ≠ 0, z = Projectivization.mk k v hv} + +private theorem eval_smul_of_isHomogeneous + (P : MvPolynomial (Fin n) k) (d : ℕ) (hP : P.IsHomogeneous d) + (a : k) (v : Fin n → k) : + MvPolynomial.eval (a • v) P = a ^ d * MvPolynomial.eval v P := by + simp only [MvPolynomial.eval_eq'] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro s hs + have hd : ∑ i, s i = d := by + rw [← s.sum_fintype (fun _ c => c) (fun _ => rfl)] + simpa [MvPolynomial.IsHomogeneous, Finsupp.weight_apply] using + hP (MvPolynomial.mem_support_iff.mp hs) + simp only [Pi.smul_apply, smul_eq_mul, mul_pow, Finset.prod_mul_distrib] + rw [Finset.prod_pow_eq_pow_sum, hd] + ring + +theorem mk_mem_projectiveHomogeneousClosure_of_fibre_zeroLocus + (I : Ideal (MvPolynomial (Fin n) k)) (ξ : Fin n → k) (hξ : ξ ≠ 0) + (hvan : ξ ∈ MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k (smoothConormalFibreProjection I))) : + Projectivization.mk k ξ hξ ∈ + projectiveHomogeneousClosure + (projectivizedDirectionSet (smoothConormalDirectionSet I)) := by + intro P d hP hT + obtain ⟨i, hi⟩ : ∃ i, ξ i ≠ 0 := by + simpa [funext_iff] using hξ + have hXPvan : MvPolynomial.X i * P ∈ MvPolynomial.vanishingIdeal k + (smoothConormalFibreProjection I) := by + rw [MvPolynomial.mem_vanishingIdeal_iff] + intro v hv + by_cases hv0 : v = 0 + · subst v + simp + · have hproj : Projectivization.mk k v hv0 ∈ + projectivizedDirectionSet (smoothConormalDirectionSet I) := by + rcases hv with ⟨y, hy, hc⟩ + exact ⟨v, ⟨y, hy, hv0, hc⟩, hv0, rfl⟩ + change MvPolynomial.eval v (MvPolynomial.X i * P) = 0 + rw [MvPolynomial.eval_mul, MvPolynomial.eval_X] + rw [hT hproj v hv0 rfl, mul_zero] + intro v hv hz + obtain ⟨a, ha⟩ := (Projectivization.mk_eq_mk_iff k ξ v hξ hv).mp hz + have hξXP : MvPolynomial.eval ξ (MvPolynomial.X i * P) = 0 := + (MvPolynomial.mem_zeroLocus_iff.mp hvan) _ hXPvan + have hξP : MvPolynomial.eval ξ P = 0 := by + rw [MvPolynomial.eval_mul, MvPolynomial.eval_X] at hξXP + exact (mul_eq_zero.mp hξXP).resolve_left hi + have hscaled := eval_smul_of_isHomogeneous P d hP (a : k) v + have ha' : (a : k) • v = ξ := by + rw [← Units.smul_def] + exact ha + rw [ha', hξP] at hscaled + exact (mul_eq_zero.mp hscaled.symm).resolve_left + (pow_ne_zero d (Units.ne_zero a)) + +end + +end Stafford38.Geometry.ProjectiveConormalDirections diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveDivisorOrderGap.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveDivisorOrderGap.lean new file mode 100644 index 0000000000..b6e186f7eb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveDivisorOrderGap.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorAxisLift +import Mathlib.RingTheory.PowerSeries.Inverse + +/-! +# The strict projective order gap at a divisor + +This file formalizes the first valuation-theoretic implication in the +normalization-at-infinity argument. Let `q₀` be the projective denominator +and let `r = q₁ / q₀` be the distinguished affine coordinate in the local +ring at a prime divisor. If both `q₀` and `r` vanish at the divisor, then a +uniformizer `ϖ` gives + +`q₀ = ϖ^a u₀`, `q₁ = ϖ^b u₁`, and `0 < a < b`. + +The power-series specialization feeds this strict order gap directly into +`FormalDivisorAxisLift`. Thus its caller no longer has to supply the +integers `a,b`, their factorizations, or the inequality `a < b`. + +This does not construct the projective closure, its normalization, or the +prime divisor. Those global existence statements are not presently +available in Mathlib's algebraic-geometry library. +-/ + +namespace Stafford38.Geometry.ProjectiveDivisorOrderGap + +open IsLocalRing +open Stafford38.GeometryFormalDivisorAxisLift +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryPowerSeriesTangentLimit +open Stafford38.GeometryRetractionSpecialization +open Stafford38.GeometrySplitTangentMatrix + +noncomputable section + +universe u v w + +/-! ## The DVR order calculation -/ + +/-- At a prime divisor, a nonzero projective denominator and a nonzero affine +coordinate which both vanish have strictly separated orders after +rehomogenization. + +The equation `q₁ = q₀ * ratio` is the local-ring form of +`ratio = X₁ / X₀`; unlike division in the fraction field, it retains the +integrality needed by the formal-divisor consumer. -/ +theorem exists_uniformizer_strict_orderGap + {R : Type u} [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] + (uniformizer : R) (huniformizer : Irreducible uniformizer) + (q₀ ratio q₁ : R) + (hq₀_ne : q₀ ≠ 0) (hratio_ne : ratio ≠ 0) + (hq₀_vanish : q₀ ∈ maximalIdeal R) + (hratio_vanish : ratio ∈ maximalIdeal R) + (hq₁ : q₁ = q₀ * ratio) : + ∃ (a r b : ℕ) (u₀ ur u₁ : Rˣ), + 0 < a ∧ 0 < r ∧ b = a + r ∧ a < b ∧ + q₀ = (u₀ : R) * uniformizer ^ a ∧ + ratio = (ur : R) * uniformizer ^ r ∧ + u₁ = u₀ * ur ∧ + q₁ = (u₁ : R) * uniformizer ^ b := by + obtain ⟨a, u₀, hq₀⟩ := + IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hq₀_ne huniformizer + obtain ⟨r, ur, hratio⟩ := + IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hratio_ne huniformizer + have hq₀_nonunit : ¬IsUnit q₀ := by + simpa only [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] using hq₀_vanish + have hratio_nonunit : ¬IsUnit ratio := by + simpa only [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] using hratio_vanish + have ha : 0 < a := by + apply Nat.pos_of_ne_zero + intro ha0 + apply hq₀_nonunit + rw [hq₀, ha0, pow_zero, mul_one] + exact u₀.isUnit + have hr : 0 < r := by + apply Nat.pos_of_ne_zero + intro hr0 + apply hratio_nonunit + rw [hratio, hr0, pow_zero, mul_one] + exact ur.isUnit + let b := a + r + let u₁ := u₀ * ur + refine ⟨a, r, b, u₀, ur, u₁, ha, hr, rfl, ?_, hq₀, hratio, rfl, ?_⟩ + · simp only [b] + omega + · rw [hq₁, hq₀, hratio] + simp only [b, u₁, Units.val_mul, pow_add] + ring + +/-! ## The completed local power-series form -/ + +/-- The DVR implication above specialized to the completed divisor chart. +Vanishing is expressed by zero constant coefficient. The output is exactly +the pair of factorizations and strict inequality consumed by +`exists_formalDivisorAxisLift`. -/ +theorem exists_powerSeries_strict_projectiveOrderGap + {k : Type u} [Field k] + (q₀ ratio q₁ : PowerSeries k) + (hq₀_ne : q₀ ≠ 0) (hratio_ne : ratio ≠ 0) + (hq₀_vanish : PowerSeries.constantCoeff q₀ = 0) + (hratio_vanish : PowerSeries.constantCoeff ratio = 0) + (hq₁ : q₁ = q₀ * ratio) : + ∃ (a b : ℕ) (u₀ u₁ : PowerSeries k), + 0 < a ∧ a < b ∧ + q₀ = (PowerSeries.X : PowerSeries k) ^ a * u₀ ∧ + PowerSeries.constantCoeff u₀ ≠ 0 ∧ + q₁ = (PowerSeries.X : PowerSeries k) ^ b * u₁ ∧ + PowerSeries.constantCoeff u₁ ≠ 0 := by + have hq₀_mem : q₀ ∈ IsLocalRing.maximalIdeal (PowerSeries k) := by + rw [← PowerSeries.ker_coeff_eq_max_ideal] + exact hq₀_vanish + have hratio_mem : ratio ∈ IsLocalRing.maximalIdeal (PowerSeries k) := by + rw [← PowerSeries.ker_coeff_eq_max_ideal] + exact hratio_vanish + obtain ⟨a, r, b, u₀, ur, u₁, ha, hr, hb, hab, + hq₀_factor, hratio_factor, hu₁, hq₁_factor⟩ := + exists_uniformizer_strict_orderGap + (PowerSeries.X : PowerSeries k) PowerSeries.X_irreducible + q₀ ratio q₁ hq₀_ne hratio_ne hq₀_mem hratio_mem hq₁ + have hu₀_const : PowerSeries.constantCoeff (u₀ : PowerSeries k) ≠ 0 := by + exact (PowerSeries.isUnit_iff_constantCoeff.mp u₀.isUnit).ne_zero + have hu₁_const : PowerSeries.constantCoeff (u₁ : PowerSeries k) ≠ 0 := by + exact (PowerSeries.isUnit_iff_constantCoeff.mp u₁.isUnit).ne_zero + refine ⟨a, b, (u₀ : PowerSeries k), (u₁ : PowerSeries k), + ha, hab, ?_, hu₀_const, ?_, hu₁_const⟩ + · simpa [mul_comm] using hq₀_factor + · simpa [mul_comm] using hq₁_factor + +/-! ## Direct handoff to the formal tangent producer -/ + +/-- A completed projective-divisor chart with vanishing denominator and +vanishing affine ratio produces the exact formal tangent annihilator whose +residue is the distinguished projective axis. + +The tangent divisibility assumptions are coordinate-free order statements: +divisor-tangent derivatives of `q₀` and `q₁` remain divisible by those +coordinates. The theorem converts them to the explicit uniformizer powers +required by `FormalDivisorAxisLift`. -/ +theorem exists_formalDivisorAxisLift_of_projectiveRatio + {k : Type u} [Field k] [CharZero k] + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (q : ι → PowerSeries k) + (Z : Matrix ι κ (PowerSeries k)) + (rows : κ ↪ ι) (chart zero axis : ι) + (ratio : PowerSeries k) + (hqchart : q chart = 1) + (hZchart : ∀ j, Z chart j = 0) + (hqzero_ne : q zero ≠ 0) + (hratio_ne : ratio ≠ 0) + (hqzero_vanish : PowerSeries.constantCoeff (q zero) = 0) + (hratio_vanish : PowerSeries.constantCoeff ratio = 0) + (hqaxis : q axis = q zero * ratio) + (hZzero_dvd : ∀ j, q zero ∣ Z zero j) + (hZaxis_dvd : ∀ j, q axis ∣ Z axis j) + (hminor : + PowerSeries.constantCoeff + (selectedMinor Z rows).det ≠ 0) : + ∃ (tau : ι → PowerSeries k) + (C : Matrix (FormalTangentColumn κ) ι (PowerSeries k)) + (ell : ι → PowerSeries k), + C * formalTangentMatrix q Z tau = 1 ∧ + rowMul ell (formalTangentMatrix q Z tau) = 0 ∧ + residueColumn ell = axisRow (k := k) axis := by + obtain ⟨a, b, u₀, u₁, ha, hab, hqzero_factor, hu₀, + hqaxis_factor, hu₁⟩ := + exists_powerSeries_strict_projectiveOrderGap + (q zero) ratio (q axis) hqzero_ne hratio_ne + hqzero_vanish hratio_vanish hqaxis + have hZzero : ∀ j, ∃ w : PowerSeries k, + Z zero j = (PowerSeries.X : PowerSeries k) ^ a * w := by + intro j + obtain ⟨w, hw⟩ := hZzero_dvd j + refine ⟨u₀ * w, ?_⟩ + rw [hw, hqzero_factor] + ring + have hZaxis : ∀ j, ∃ w : PowerSeries k, + Z axis j = (PowerSeries.X : PowerSeries k) ^ b * w := by + intro j + obtain ⟨w, hw⟩ := hZaxis_dvd j + refine ⟨u₁ * w, ?_⟩ + rw [hw, hqaxis_factor] + ring + obtain ⟨lambda, c, tau, C, ell, _hlambda, _hselected, + _htauchart, _htauselected, _hc, _hfactor, _hprimitive, + _htauaxis, _haxiscolumns, hleft, hrow, hresidue⟩ := + exists_formalDivisorAxisLift q Z rows chart zero axis a b u₀ u₁ + hqchart hZchart ha hab hqzero_factor hu₀ hZzero + hqaxis_factor hZaxis hminor + exact ⟨tau, C, ell, hleft, hrow, hresidue⟩ + + +end + +end Stafford38.Geometry.ProjectiveDivisorOrderGap diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveEquationFormalChart.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveEquationFormalChart.lean new file mode 100644 index 0000000000..53fcedd3ef --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveEquationFormalChart.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorLaurentConormal +import Mathlib.RingTheory.MvPolynomial.Homogeneous + +/-! +# Projective equations on a formal affine chart + +This file removes the base-equation part of the formal-divisor producer. +A homogeneous projective equation which vanishes at a projective point also +vanishes after dehomogenizing in any nonzero chart. The result is extended +from a family of homogeneous equations to the affine ideal generated by their +dehomogenizations, and then connected directly to the formal Laurent conormal +handoff. + +No projective closure, normalization, divisor, formal parameter, smoothness, +or tangent-space equality is constructed here. Those geometric existence +statements remain outside this algebraic chart calculation. +-/ + +namespace Stafford38.Geometry.ProjectiveEquationFormalChart + +open MvPolynomial +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {K : Type*} [Field K] {n : ℕ} + +/-- Normalize every projective coordinate by the chosen chart denominator. -/ +def normalizedProjectivePoint {m : ℕ} (q : Fin m → K) (q₀ : K) : Fin m → K := + fun i ↦ q i / q₀ + +/-- Substitute `X₀ = 1` and `X_(i+1) = X_i` in a projective polynomial. -/ +def projectiveDehomogenize : + MvPolynomial (Fin (n + 1)) K →ₐ[K] MvPolynomial (Fin n) K := + MvPolynomial.aeval (Fin.cases 1 fun i ↦ MvPolynomial.X i) + +/-- Evaluation after projective dehomogenization is evaluation at the +projective chart point `(1,y)`. -/ +theorem eval_projectiveDehomogenize + (p : MvPolynomial (Fin (n + 1)) K) (y : Fin n → K) : + MvPolynomial.eval y (projectiveDehomogenize p) = + MvPolynomial.eval (Fin.cases 1 y) p := by + rw [show projectiveDehomogenize p = + MvPolynomial.bind₁ (Fin.cases 1 fun i ↦ MvPolynomial.X i) p by + rfl] + rw [MvPolynomial.hom_bind₁] + change MvPolynomial.eval₂ _ _ p = MvPolynomial.eval₂ _ _ p + have hf : (MvPolynomial.eval y).comp MvPolynomial.C = RingHom.id K := by + ext a + simp + rw [hf] + apply MvPolynomial.eval₂_congr + intro i + refine Fin.cases ?_ (fun j ↦ ?_) i <;> simp + +/-- Scaling all coordinates of a homogeneous polynomial scales its value by +the corresponding power. This explicit finite-product form is the algebraic +valuation identity used in the chart argument. -/ +theorem eval_eq_pow_mul_eval_normalizedProjectivePoint + {m : ℕ} (p : MvPolynomial (Fin m) K) (d : ℕ) + (hp : p.IsHomogeneous d) (q : Fin m → K) (q₀ : K) (hq₀ : q₀ ≠ 0) : + MvPolynomial.eval q p = + q₀ ^ d * MvPolynomial.eval (normalizedProjectivePoint q q₀) p := by + change p.eval₂ (RingHom.id K) q = + q₀ ^ d * p.eval₂ (RingHom.id K) (normalizedProjectivePoint q q₀) + rw [MvPolynomial.eval₂_eq', MvPolynomial.eval₂_eq'] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro s hs + have hdegree : ∑ i, s i = d := by + have hweight := hp (MvPolynomial.mem_support_iff.mp hs) + rw [Finsupp.weight_apply, + Finsupp.sum_fintype s + (fun i c ↦ c • (1 : Fin m → ℕ) i) (by simp)] at hweight + simpa only [Pi.one_apply, smul_eq_mul, mul_one] using hweight + have hcoordinate : ∀ i : Fin m, + q₀ * normalizedProjectivePoint q q₀ i = q i := by + intro i + exact mul_div_cancel₀ (q i) hq₀ + have hproduct : (∏ i : Fin m, q i ^ s i) = + q₀ ^ d * ∏ i : Fin m, normalizedProjectivePoint q q₀ i ^ s i := by + calc + (∏ i : Fin m, q i ^ s i) = + ∏ i : Fin m, (q₀ * normalizedProjectivePoint q q₀ i) ^ s i := by + simp_rw [hcoordinate] + _ = (∏ i : Fin m, q₀ ^ s i) * + ∏ i : Fin m, normalizedProjectivePoint q q₀ i ^ s i := by + simp_rw [mul_pow] + rw [Finset.prod_mul_distrib] + _ = q₀ ^ d * + ∏ i : Fin m, normalizedProjectivePoint q q₀ i ^ s i := by + rw [Finset.prod_pow_eq_pow_sum, hdegree] + rw [hproduct] + ring + +/-- The normalized projective point is exactly `(1, dehomogenizedPoint q)` +in the chart with denominator `q 0`. -/ +theorem normalizedProjectivePoint_eq_chartPoint + (q : Fin (n + 1) → K) (hq₀ : q 0 ≠ 0) : + normalizedProjectivePoint q (q 0) = + Fin.cases 1 (dehomogenizedPoint q) := by + funext i + refine Fin.cases ?_ (fun j ↦ ?_) i + · simp [normalizedProjectivePoint, hq₀] + · rfl + +/-- A homogeneous projective equation vanishing at `q` gives a vanishing +affine equation after dehomogenization in the nonzero zeroth chart. -/ +theorem eval_projectiveDehomogenize_eq_zero_of_homogeneous + (p : MvPolynomial (Fin (n + 1)) K) (d : ℕ) + (hp : p.IsHomogeneous d) (q : Fin (n + 1) → K) + (hq₀ : q 0 ≠ 0) (hvanish : MvPolynomial.eval q p = 0) : + MvPolynomial.eval (dehomogenizedPoint q) (projectiveDehomogenize p) = 0 := by + have hscale := eval_eq_pow_mul_eval_normalizedProjectivePoint + p d hp q (q 0) hq₀ + rw [hvanish] at hscale + have hnormalized : + MvPolynomial.eval (normalizedProjectivePoint q (q 0)) p = 0 := + (mul_eq_zero.mp hscale.symm).resolve_left (pow_ne_zero d hq₀) + rw [eval_projectiveDehomogenize, + ← normalizedProjectivePoint_eq_chartPoint q hq₀] + exact hnormalized + +/-- The affine ideal generated by dehomogenizing a supplied family of +projective equations. -/ +def dehomogenizedEquationIdeal {I : Type*} + (equations : I → MvPolynomial (Fin (n + 1)) K) : + Ideal (MvPolynomial (Fin n) K) := + Ideal.span (Set.range fun i ↦ projectiveDehomogenize (equations i)) + +/-- Vanishing descends not only for each homogeneous generator but for every +element of the affine ideal generated by their dehomogenizations. -/ +theorem eval_eq_zero_of_mem_dehomogenizedEquationIdeal + {I : Type*} (equations : I → MvPolynomial (Fin (n + 1)) K) + (degree : I → ℕ) + (hhomogeneous : ∀ i, (equations i).IsHomogeneous (degree i)) + (q : Fin (n + 1) → K) (hq₀ : q 0 ≠ 0) + (hvanish : ∀ i, MvPolynomial.eval q (equations i) = 0) + (f : MvPolynomial (Fin n) K) + (hf : f ∈ dehomogenizedEquationIdeal equations) : + MvPolynomial.eval (dehomogenizedPoint q) f = 0 := by + have hle : dehomogenizedEquationIdeal equations ≤ + RingHom.ker (MvPolynomial.eval (dehomogenizedPoint q)) := by + apply Ideal.span_le.mpr + rintro _ ⟨i, rfl⟩ + change MvPolynomial.eval (dehomogenizedPoint q) + (projectiveDehomogenize (equations i)) = 0 + exact eval_projectiveDehomogenize_eq_zero_of_homogeneous + (equations i) (degree i) (hhomogeneous i) q hq₀ (hvanish i) + exact hle hf + +/-- Direct formal-chart handoff. For the affine ideal generated by the +dehomogenized homogeneous projective equations, projective vanishing supplies +the complete base-equation hypothesis required by +`FormalDivisorLaurentConormal`. Only the exact tangent-space identification +remains as geometric input. -/ +theorem laurentPhasePoint_mem_dehomogenizedEquationConormalLocus + {k : Type*} [Field k] {I κ : Type*} [Fintype κ] + (equations : I → MvPolynomial (Fin (n + 1)) (LaurentSeries k)) + (degree : I → ℕ) + (hhomogeneous : ∀ i, (equations i).IsHomogeneous (degree i)) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq₀ : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hvanish : ∀ i, MvPolynomial.eval (laurentColumn q) (equations i) = 0) + (htangent : + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau) = + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (dehomogenizedEquationIdeal equations)) : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ laurentColumn ell i.succ) ∈ + equationConormalLocus (dehomogenizedEquationIdeal equations) := by + apply laurentPhasePoint_mem_equationConormalLocus + (dehomogenizedEquationIdeal equations) q ell Z tau hq₀ hrow + · intro f hf + exact eval_eq_zero_of_mem_dehomogenizedEquationIdeal + equations degree hhomogeneous (laurentColumn q) + (laurentColumn_ne_zero_of_ne_zero q hq₀) hvanish f hf + · exact htangent + + +end + +end Stafford38.Geometry.ProjectiveEquationFormalChart diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveTangentInclusion.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveTangentInclusion.lean new file mode 100644 index 0000000000..f54c69903a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveTangentInclusion.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.FormalDivisorLaurentConormal + +/-! +# Projective tangent inclusion is enough for affine conormality + +The projective dehomogenization bridge does not need equality between the +Zariski tangent space and the span of the supplied dehomogenized columns. +It is enough that the Zariski tangent space is contained in that span: a +covector annihilating the larger space then annihilates the smaller one. + +This file propagates that weaker hypothesis through the existing formal +divisor and Laurent-direction consumers. It constructs no projective chart, +normalization, tangent comparison, or conormal-closure theorem. +-/ + +namespace Stafford38.Geometry.ProjectiveTangentInclusion + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.LaurentConormalDirection +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.GeometryFormalDivisorTangent +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + +variable {K : Type*} [Field K] {n : ℕ} + +/-- A projective annihilating row gives an affine conormal covector whenever +the Zariski tangent space is contained in the dehomogenized column span. +Equality of the two tangent spaces is not required. -/ +theorem coordinateCovector_mem_affineConormalSpace_of_zariski_le_span + {κ : Type*} + (I : Ideal (MvPolynomial (Fin n) K)) + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint q) I ≤ + dehomogenizedTangentSpan q B) : + coordinateCovector (fun i ↦ ell i.succ) ∈ + affineConormalSpace (dehomogenizedPoint q) I := by + rw [affineConormalSpace, Submodule.mem_dualAnnihilator] + intro v hv + have hann := + coordinateCovector_mem_dehomogenizedTangentSpan_dualAnnihilator + q ell B hq0 hq hB + rw [Submodule.mem_dualAnnihilator] at hann + exact hann v (htangent hv) + +/-- The weakened projective bridge reaches the equation-defined affine +conormal locus directly. -/ +theorem phasePoint_mem_equationConormalLocus_of_zariski_le_span + {κ : Type*} + (I : Ideal (MvPolynomial (Fin n) K)) + (q ell : Fin (n + 1) → K) (B : Matrix (Fin (n + 1)) κ K) + (hq0 : q 0 ≠ 0) + (hq : ∑ i, ell i * q i = 0) + (hB : rowMul ell B = 0) + (hbase : ∀ f ∈ I, MvPolynomial.eval (dehomogenizedPoint q) f = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint q) I ≤ + dehomogenizedTangentSpan q B) : + Sum.elim (dehomogenizedPoint q) (fun i ↦ ell i.succ) ∈ + equationConormalLocus I := by + refine ⟨?_, ?_⟩ + · simpa using hbase + · simpa using coordinateCovector_mem_affineConormalSpace_of_zariski_le_span + I q ell B hq0 hq hB htangent + +variable {k : Type*} [Field k] + +/-- Formal row annihilation reaches the Laurent-valued equation-conormal +locus under tangent inclusion rather than tangent equality. -/ +theorem laurentPhasePoint_mem_equationConormalLocus_of_zariski_le_span + {κ : Type*} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) (LaurentSeries k))) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ I, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) I ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau)) : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ laurentColumn ell i.succ) ∈ + equationConormalLocus I := by + exact phasePoint_mem_equationConormalLocus_of_zariski_le_span + I (laurentColumn q) (laurentColumn ell) + (laurentNonpositionTangentMatrix Z tau) + (laurentColumn_ne_zero_of_ne_zero q hq0) + (laurentColumn_dot_eq_zero_of_formalTangent_rowMul q ell Z tau hrow) + (laurentNonposition_rowMul_eq_zero_of_formalTangent_rowMul + q ell Z tau hrow) + hbase htangent + +/-- The weakened Laurent bridge retains the exact fibre-residue identity. -/ +theorem laurentPhasePoint_mem_equationConormalLocus_and_residue_of_zariski_le_span + {κ : Type*} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) (LaurentSeries k))) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ I, + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) I ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau)) : + Sum.elim (dehomogenizedPoint (laurentColumn q)) + (fun i ↦ laurentColumn ell i.succ) ∈ equationConormalLocus I ∧ + residueColumn (fun i : Fin n ↦ ell i.succ) = + fun i ↦ residueColumn ell i.succ := by + exact ⟨laurentPhasePoint_mem_equationConormalLocus_of_zariski_le_span + I q ell Z tau hq0 hrow hbase htangent, residueColumn_tail ell⟩ + +/-- The same inclusion hypothesis reaches the projected Laurent +equation-conormal direction closure required by the asymptotic consumer. -/ +theorem residue_tail_mem_laurentEquationConormalDirectionClosure_of_zariski_le_span + {κ : Type*} [Fintype κ] + (I : Ideal (MvPolynomial (Fin n) k)) + (q ell : Fin (n + 1) → PowerSeries k) + (Z : Matrix (Fin (n + 1)) κ (PowerSeries k)) + (tau : Fin (n + 1) → PowerSeries k) + (hq0 : q 0 ≠ 0) + (hrow : rowMul ell (formalTangentMatrix q Z tau) = 0) + (hbase : ∀ f ∈ + I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n)), + MvPolynomial.eval (dehomogenizedPoint (laurentColumn q)) f = 0) + (htangent : + zariskiTangentSpace (dehomogenizedPoint (laurentColumn q)) + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) ≤ + dehomogenizedTangentSpan (laurentColumn q) + (laurentNonpositionTangentMatrix Z tau)) : + residueColumn (fun i : Fin n ↦ ell i.succ) ∈ + laurentEquationConormalDirectionClosure I := by + apply residue_mem_laurentEquationConormalDirectionClosure + I (dehomogenizedPoint (laurentColumn q)) (fun i : Fin n ↦ ell i.succ) + exact laurentPhasePoint_mem_equationConormalLocus_of_zariski_le_span + (I.map (scalarPolynomialMap + (k := k) (K := LaurentSeries k) (Fin n))) + q ell Z tau hq0 hrow hbase htangent + + +end + +end Stafford38.Geometry.ProjectiveTangentInclusion diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveValuationNormalization.lean b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveValuationNormalization.lean new file mode 100644 index 0000000000..c1f10b6ae3 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ProjectiveValuationNormalization.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Localization.Integer +import Mathlib.RingTheory.Valuation.ValuationSubring +import Mathlib.RingTheory.Filtration +import Mathlib.RingTheory.AdicCompletion.Algebra + +/-! +# Finite projective normalization in a valuation subring + +A finite nonzero vector over the fraction field of a valuation ring can be +scaled into the valuation ring so that one coordinate is exactly one. The +same scalar is used in every coordinate, so all projective ratios and +homogeneous equations are preserved. +-/ + +namespace Stafford38.Geometry.ProjectiveValuationNormalization + +noncomputable section + +universe u v + +/-- The canonical map from a Noetherian local ring into its proper-ideal +adic completion is injective. -/ +theorem adicCompletion_algebraMap_injective + {R : Type u} [CommRing R] [IsNoetherianRing R] [IsLocalRing R] + (I : Ideal R) (hI : I ≠ ⊤) : + Function.Injective (algebraMap R (AdicCompletion I R)) := by + intro x y hxy + apply sub_eq_zero.mp + have hmem : x - y ∈ ⨅ n : ℕ, I ^ n := by + rw [Ideal.mem_iInf] + intro n + have heval := congrArg + (fun z ↦ (AdicCompletion.eval I R n) z) hxy + change (I ^ n • ⊤ : Ideal R).mkQ x = + (I ^ n • ⊤ : Ideal R).mkQ y at heval + simpa using (Submodule.Quotient.eq (I ^ n • ⊤ : Ideal R)).mp heval + rw [Ideal.iInf_pow_eq_bot_of_isLocalRing I hI] at hmem + exact hmem + +/-- A finite family in a valuation ring has a member dividing every member. -/ +theorem exists_index_dvd_all + {R : Type u} [CommRing R] [IsDomain R] [ValuationRing R] + {ι : Type v} [Fintype ι] [Nonempty ι] (a : ι → R) : + ∃ c, ∀ i, a c ∣ a i := by + classical + let s : Finset (Associates R) := + Finset.univ.image fun i ↦ Associates.mk (a i) + have hs : s.Nonempty := by + let i : ι := Classical.choice inferInstance + exact ⟨Associates.mk (a i), Finset.mem_image.2 + ⟨i, Finset.mem_univ i, rfl⟩⟩ + obtain ⟨m, hm, hminimal⟩ := s.exists_minimal hs + obtain ⟨c, -, hc⟩ := Finset.mem_image.mp hm + refine ⟨c, fun i ↦ Associates.dvd_of_mk_le_mk ?_⟩ + have hi : Associates.mk (a i) ∈ s := + Finset.mem_image.2 ⟨i, Finset.mem_univ i, rfl⟩ + rw [hc] + by_contra hnot + have hnotdvd : ¬a c ∣ a i := by + intro h + apply hnot + rw [← hc] + exact Associates.mk_le_mk_of_dvd h + have hreverse : Associates.mk (a i) ≤ m := by + rw [← hc] + exact Associates.mk_le_mk_of_dvd + ((ValuationRing.dvd_total (a c) (a i)).resolve_left hnotdvd) + exact hnot (hminimal hi hreverse) + +/-- A finite nonzero projective vector over a field has a common normalized +lift to any valuation subring of that field. -/ +theorem exists_normalized_projective_lift + {K : Type u} [Field K] (V : ValuationSubring K) + {ι : Type v} [Fintype ι] [Nonempty ι] + (f : ι → K) (hf : ∃ i, f i ≠ 0) : + ∃ (chart : ι) (q : ι → V) (scale : K), + scale ≠ 0 ∧ q chart = 1 ∧ + ∀ i, (q i : K) = scale * f i := by + classical + obtain ⟨b, hb⟩ := + IsLocalization.exist_integer_multiples_of_finite + (nonZeroDivisors V) f + let a : ι → V := fun i ↦ (hb i).choose + have ha : ∀ i, algebraMap V K (a i) = + algebraMap V K (b : V) * f i := by + intro i + simpa only [a, Algebra.smul_def] using (hb i).choose_spec + obtain ⟨chart, hchart⟩ := exists_index_dvd_all a + let q : ι → V := fun i ↦ + if h : i = chart then 1 else (hchart i).choose + have haq : ∀ i, a i = a chart * q i := by + intro i + by_cases h : i = chart + · subst i + simp [q] + · simpa [q, h] using (hchart i).choose_spec + have hb_ne : (b : V) ≠ 0 := + mem_nonZeroDivisors_iff_ne_zero.mp b.property + have hbK_ne : algebraMap V K (b : V) ≠ 0 := + (IsFractionRing.injective V K).ne hb_ne + have hchart_ne : a chart ≠ 0 := by + obtain ⟨i, hi⟩ := hf + intro hzero + have hai : a i = 0 := by rw [haq i, hzero, zero_mul] + have : algebraMap V K (b : V) * f i = 0 := by + rw [← ha i, hai, map_zero] + exact hi ((mul_eq_zero.mp this).resolve_left hbK_ne) + have hchartK_ne : algebraMap V K (a chart) ≠ 0 := + (IsFractionRing.injective V K).ne hchart_ne + let scale : K := algebraMap V K (b : V) / algebraMap V K (a chart) + refine ⟨chart, q, scale, div_ne_zero hbK_ne hchartK_ne, ?_, ?_⟩ + · simp [q] + · intro i + change algebraMap V K (q i) = scale * f i + apply mul_left_cancel₀ hchartK_ne + change algebraMap V K (a chart) * algebraMap V K (q i) = + algebraMap V K (a chart) * (scale * f i) + calc + algebraMap V K (a chart) * algebraMap V K (q i) = + algebraMap V K (a chart * q i) := by rw [map_mul] + _ = algebraMap V K (a i) := by rw [← haq i] + _ = algebraMap V K (b : V) * f i := ha i + _ = algebraMap V K (a chart) * (scale * f i) := by + dsimp [scale] + calc + algebraMap V K (b : V) * f i = + (algebraMap V K (a chart) * + (algebraMap V K (a chart))⁻¹) * + (algebraMap V K (b : V) * f i) := by + rw [mul_inv_cancel₀ hchartK_ne, one_mul] + _ = algebraMap V K (a chart) * + ((algebraMap V K (b : V) / + algebraMap V K (a chart)) * f i) := by + rw [div_eq_mul_inv] + ring + + +end + +end Stafford38.Geometry.ProjectiveValuationNormalization diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RelativeCoefficientDVRPlace.lean b/LeanPool/Stafford38/Stafford38/Geometry/RelativeCoefficientDVRPlace.lean new file mode 100644 index 0000000000..aa657c9f17 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RelativeCoefficientDVRPlace.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.RetainedDVRPlace +import Mathlib.FieldTheory.Separable + +/-! +# Relative coefficients in a retained DVR place + +For the source DVR `E[X]_(X)`, the retained local factor contains the +coefficient field `E`. This file constructs that coefficient map, checks its +compatibility with the ambient-field embedding, and proves that the resulting +residue extension is finite and separable in characteristic zero. + +No inverse limit, completion, or power-series chart is constructed here. +-/ + +namespace Stafford38.Geometry.RelativeCoefficientDVR + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.RetainedDVR + +noncomputable section + + +universe u v + +private abbrev SourceDVR (E : Type u) [Field E] := + CoordinateZeroLocalRing E + +/-- Evaluation at zero on the source coordinate DVR. -/ +def coordinateConstantTerm + (E : Type u) [Field E] : SourceDVR E →+* E := + IsLocalization.lift (S := SourceDVR E) + (M := (coordinateZeroPrime E).primeCompl) + (g := Polynomial.evalRingHom (0 : E)) fun y ↦ by + rw [isUnit_iff_ne_zero] + intro hy + apply y.2 + have hker : + RingHom.ker (Polynomial.evalRingHom (0 : E)) = + coordinateZeroPrime E := by + rw [Polynomial.ker_evalRingHom, coordinateZeroPrime] + have hCzero : Polynomial.C (0 : E) = 0 := + map_zero Polynomial.C + rw [hCzero, sub_zero] + exact hker.le (RingHom.mem_ker.mpr hy) + +/-- Evaluation at zero is onto because constant polynomials survive the +localization. -/ +theorem coordinateConstantTerm_surjective + (E : Type u) [Field E] : + Function.Surjective (coordinateConstantTerm E) := by + intro e + refine ⟨algebraMap (Polynomial E) (SourceDVR E) (Polynomial.C e), ?_⟩ + rw [coordinateConstantTerm, IsLocalization.lift_eq] + exact Polynomial.eval_C + +/-- The residue field of `E[X]_(X)` is canonically `E`. -/ +noncomputable def coordinateResidueEquiv + (E : Type u) [Field E] : + ResidueField (SourceDVR E) ≃+* E := by + let f := coordinateConstantTerm E + letI : IsLocalHom f := (coordinateConstantTerm_surjective E).isLocalHom + let g : ResidueField (SourceDVR E) →+* E := ResidueField.lift f + apply RingEquiv.ofBijective g + refine ⟨g.injective, ?_⟩ + intro e + obtain ⟨a, rfl⟩ := coordinateConstantTerm_surjective E e + exact ⟨residue (SourceDVR E) a, ResidueField.lift_residue_apply f a⟩ + +@[simp] +theorem coordinateResidueEquiv_algebraMap + (E : Type u) [Field E] (e : E) : + coordinateResidueEquiv E + (algebraMap E (ResidueField (SourceDVR E)) e) = e := by + letI : IsLocalHom (coordinateConstantTerm E) := + (coordinateConstantTerm_surjective E).isLocalHom + change ResidueField.lift (coordinateConstantTerm E) + (residue (SourceDVR E) + (algebraMap E (SourceDVR E) e)) = e + rw [ResidueField.lift_residue_apply] + change coordinateConstantTerm E + (algebraMap (Polynomial E) (SourceDVR E) (Polynomial.C e)) = e + rw [coordinateConstantTerm, IsLocalization.lift_eq] + exact Polynomial.eval_C + +/-- The retained local factor restricted to constant coefficients. -/ +def relativeCoefficientMap + (E : Type u) [Field E] + {L : Type v} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + E →+* D.valuation.toSubring := + D.factor.comp (algebraMap E (SourceDVR E)) + +/-- The coefficient map retained in the valuation subring is the original +ambient embedding of `E`. -/ +theorem relativeCoefficientMap_commutes + (E : Type u) [Field E] + {L : Type v} [Field L] [Algebra E L] + [Algebra (SourceDVR E) L] [IsScalarTower E (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + D.valuation.toSubring.subtype.comp (relativeCoefficientMap E D) = + algebraMap E L := by + ext e + change (D.factor (algebraMap E (SourceDVR E) e) : L) = + algebraMap E L e + calc + (D.factor (algebraMap E (SourceDVR E) e) : L) = + algebraMap (SourceDVR E) L + (algebraMap E (SourceDVR E) e) := + DFunLike.congr_fun D.factor_commutes + (algebraMap E (SourceDVR E) e) + _ = algebraMap E L e := + (IsScalarTower.algebraMap_apply E (SourceDVR E) L e).symm + +/-- The finite residue extension retained from the source DVR remains finite +over its coefficient field. -/ +theorem relativeResidue_finite + (E : Type u) [Field E] + {L : Type v} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + Module.Finite E (ResidueField D.valuation.toSubring) := by + let A := SourceDVR E + let V := D.valuation.toSubring + letI : IsDiscreteValuationRing V := D.isDiscrete + letI : Algebra A V := D.factor.toAlgebra + letI : IsLocalHom (algebraMap A V) := D.factor_isLocal + letI : Algebra E V := (relativeCoefficientMap E D).toAlgebra + letI : IsScalarTower E A V := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + have hsourceSurjective : + Function.Surjective (algebraMap E (ResidueField A)) := by + intro z + refine ⟨coordinateResidueEquiv E z, ?_⟩ + apply (coordinateResidueEquiv E).injective + exact coordinateResidueEquiv_algebraMap E + (coordinateResidueEquiv E z) + have hsourceFinite : Module.Finite E (ResidueField A) := + Module.Finite.of_surjective + (Algebra.linearMap E (ResidueField A)) hsourceSurjective + letI : Module.Finite E (ResidueField A) := hsourceFinite + have htargetFinite : + Module.Finite (ResidueField A) (ResidueField V) := by + exact D.residue_finite + letI : Module.Finite (ResidueField A) (ResidueField V) := htargetFinite + letI : IsScalarTower E (ResidueField A) (ResidueField V) := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + exact Module.Finite.trans (ResidueField A) (ResidueField V) + +/-- In characteristic zero, the finite residue extension induced by the +retained coefficient map is separable. -/ +theorem relativeResidue_isSeparable + (E : Type u) [Field E] [CharZero E] + {L : Type v} [Field L] [Algebra (SourceDVR E) L] + {a : SourceDVR E} + (D : RetainedDVRPlace (SourceDVR E) (L := L) a) : + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + Algebra.IsSeparable E (ResidueField D.valuation.toSubring) := by + letI : IsDiscreteValuationRing D.valuation.toSubring := D.isDiscrete + letI : Algebra E D.valuation.toSubring := + (relativeCoefficientMap E D).toAlgebra + letI : Module.Finite E (ResidueField D.valuation.toSubring) := + relativeResidue_finite E D + letI : Algebra.IsIntegral E (ResidueField D.valuation.toSubring) := + ⟨fun y ↦ (IsAlgebraic.of_finite E y).isIntegral⟩ + exact Algebra.IsSeparable.of_integral E + (ResidueField D.valuation.toSubring) + + +end + +end Stafford38.Geometry.RelativeCoefficientDVR diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RelativeDivisorialTower.lean b/LeanPool/Stafford38/Stafford38/Geometry/RelativeDivisorialTower.lean new file mode 100644 index 0000000000..4c1677064e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RelativeDivisorialTower.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialBoundaryExtension +import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis +import Mathlib.RingTheory.AlgebraicIndependent.Transcendental +import Mathlib.RingTheory.FiniteType +import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic + +/-! +# A relative transcendence tower containing a selected coordinate + +This file supplies the field-theoretic reduction immediately upstream of +`DivisorialBoundaryExtension`. A selected transcendental element is extended +to a transcendence basis. Removing that element gives a relative coefficient +field `E`; adjoining the element back recovers the full basis field. For a +finitely generated ambient field, the extension over the full basis field is +finite, and in characteristic zero it is separable. + +The output is deliberately stated with actual intermediate fields in the +ambient field. It does not pretend that the remaining identification +`Frac(E[X]_(X)) = E(x)` is definitional: that canonical fraction-field +comparison, together with transport of the finite-dimensional instance, is +the next formal interface needed by the existing divisorial-extension theorem. +-/ + +namespace Stafford38.Geometry.RelativeDivisorialTower + +open Set + +noncomputable section + +universe u v + +/-- A transcendental element belongs to some transcendence basis. Unlike the +empty-seed library theorem, this version retains the prescribed element. -/ +theorem exists_transcendenceBasis_containing + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (x : K) (hx : Transcendental k x) : + ∃ s : Set K, x ∈ s ∧ + IsTranscendenceBasis k ((↑) : s → K) := by + have hsingleton : + AlgebraicIndependent k ((↑) : ({x} : Set K) → K) := by + rw [algebraicIndependent_singleton_iff ⟨x, Set.mem_singleton x⟩] + exact hx + obtain ⟨s, hxs, hsmax⟩ := + exists_maximal_algebraicIndependent ({x} : Set K) Set.univ + (Set.subset_univ _) hsingleton + refine ⟨s, hxs (Set.mem_singleton x), hsmax.1.1, ?_⟩ + intro t ht hst + have hrs : Set.range ((↑) : s → K) = s := Subtype.range_coe + rw [hrs] at hst ⊢ + apply hsmax.eq_of_le ⟨ht, Set.subset_univ _⟩ + exact hst + +/-- The relative coefficient field obtained by deleting `x` from a basis. -/ +abbrev coefficientField + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (s : Set K) (x : K) : IntermediateField k K := + IntermediateField.adjoin k (s \ {x}) + +/-- The field generated by a set is algebraic over the ordinary algebra +generated by that set. Concretely, field-adjoin induction adds only inverses +to the algebraic closure operations. -/ +theorem intermediateAdjoin_isAlgebraic_over_algebraAdjoin + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (t : Set K) : + let R := Algebra.adjoin k t + let E := IntermediateField.adjoin k t + letI : Algebra R E := + (Subalgebra.inclusion + (IntermediateField.algebra_adjoin_le_adjoin k t)).toAlgebra + Algebra.IsAlgebraic R E := by + dsimp only + let R := Algebra.adjoin k t + let E := IntermediateField.adjoin k t + let hRE : R ≤ E.toSubalgebra := + IntermediateField.algebra_adjoin_le_adjoin k t + letI : Algebra R E := (Subalgebra.inclusion hRE).toAlgebra + refine ⟨fun y ↦ ?_⟩ + apply IntermediateField.adjoin_induction k + (p := fun z hz ↦ IsAlgebraic R (⟨z, hz⟩ : E)) + · intro z hz + have hmem : z ∈ E := IntermediateField.subset_adjoin k t hz + have heq : (⟨z, hmem⟩ : E) = algebraMap R E + (⟨z, Algebra.subset_adjoin hz⟩ : R) := by + apply Subtype.ext + rfl + rw [heq] + exact isAlgebraic_algebraMap _ + · intro a + have heq : (⟨algebraMap k K a, + (IntermediateField.adjoin k t).algebraMap_mem a⟩ : E) = + algebraMap R E (algebraMap k R a) := by + apply Subtype.ext + rfl + rw [heq] + exact isAlgebraic_algebraMap _ + · intro a b _ _ ha hb + exact ha.add hb + · intro a _ ha + exact ha.inv + · intro a b _ _ ha hb + exact ha.mul hb + +/-- Deleting a prescribed element from a transcendence basis leaves a +coefficient field over which that element is still transcendental. This is +the load-bearing relative-basis lemma needed to evaluate `E[X]` at `x`. -/ +theorem transcendental_over_coefficientField + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + {s : Set K} (hs : IsTranscendenceBasis k ((↑) : s → K)) + {x : K} (hx : x ∈ s) : + Transcendental (coefficientField k s x) x := by + let i : s := ⟨x, hx⟩ + let t : Set s := {j | (j : K) ≠ x} + have hi : i ∉ t := by simp [i, t] + have ht : ((fun j : s ↦ (j : K)) '' t) = s \ {x} := by + ext y + constructor + · rintro ⟨j, hj, rfl⟩ + exact ⟨j.property, by simpa [t] using hj⟩ + · rintro ⟨hy, hyx⟩ + exact ⟨⟨y, hy⟩, by simpa [t] using hyx, rfl⟩ + have htr : Transcendental (Algebra.adjoin k (s \ {x})) x := by + have h := hs.1.transcendental_adjoin (s := t) hi + rw [ht] at h + exact h + let R := Algebra.adjoin k (s \ {x}) + let E := coefficientField k s x + let hRE : R ≤ E.toSubalgebra := + IntermediateField.algebra_adjoin_le_adjoin k (s \ {x}) + letI : Algebra R E := (Subalgebra.inclusion hRE).toAlgebra + letI : Algebra R K := R.val.toRingHom.toAlgebra + letI : IsScalarTower R E K := + IsScalarTower.of_algebraMap_eq (fun _ ↦ rfl) + letI : Algebra.IsAlgebraic R E := + intermediateAdjoin_isAlgebraic_over_algebraAdjoin k (s \ {x}) + exact htr.extendScalars E + +/-- Adjoining `x` to the coefficient field obtained from `s \ {x}` recovers +the field generated by all of `s`, provided `x ∈ s`. This is the exact +relative decomposition used by the valuation construction. -/ +theorem restrictScalars_adjoin_coordinate + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (s : Set K) (x : K) (hx : x ∈ s) : + (IntermediateField.adjoin (coefficientField k s x) ({x} : Set K)).restrictScalars k = + IntermediateField.adjoin k s := by + rw [IntermediateField.adjoin_adjoin_left] + congr 1 + rw [Set.union_comm, ← Set.insert_eq, Set.insert_diff_singleton, + Set.insert_eq_of_mem hx] + +/-- A finitely generated field extension is finite over the field generated +by any transcendence basis. Finite generation here is field-theoretic +(`IntermediateField.FG`), not finite type as an algebra (which would be +impossible for a transcendental field extension). -/ +theorem finiteDimensional_over_adjoin_transcendenceBasis + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + {s : Set K} (hs : IsTranscendenceBasis k ((↑) : s → K)) : + FiniteDimensional (IntermediateField.adjoin k s) K := by + let B : IntermediateField k K := IntermediateField.adjoin k s + haveI : Algebra.IsAlgebraic B K := by + have halg := hs.isAlgebraic_field + have hrange : Set.range ((↑) : s → K) = s := Subtype.range_coe + rw [hrange] at halg + exact halg + obtain ⟨t, ht⟩ := hfg + have hBt : IntermediateField.adjoin B (t : Set K) = ⊤ := by + rw [eq_top_iff] + intro y _ + have hy : y ∈ IntermediateField.adjoin k (t : Set K) := by + rw [ht] + trivial + apply IntermediateField.adjoin_induction k + (p := fun z _ ↦ z ∈ IntermediateField.adjoin B (t : Set K)) + · intro z hz + exact IntermediateField.subset_adjoin B (t : Set K) hz + · intro a + exact (IntermediateField.adjoin B (t : Set K)).algebraMap_mem + ⟨algebraMap k K a, B.algebraMap_mem a⟩ + · exact fun _ _ _ _ ha hb ↦ add_mem ha hb + · exact fun _ _ ha ↦ inv_mem ha + · exact fun _ _ _ _ ha hb ↦ mul_mem ha hb + · exact hy + have hfieldAlg := IntermediateField.adjoin_toSubalgebra_of_isAlgebraic + (F := B) (E := K) (S := (t : Set K)) + (fun z _ ↦ Algebra.IsAlgebraic.isAlgebraic z) + rw [hBt] at hfieldAlg + letI : Algebra.FiniteType B K := ⟨⟨t, hfieldAlg.symm⟩⟩ + exact Algebra.IsIntegral.finite + +/-- The full relative tower produced from a prescribed transcendental +coordinate. It records actual fields `E ⊆ F ⊆ K`, the equality +`F|_k = k(s)`, membership of `x`, and finiteness of `K/F`. + +This is stronger than merely postulating a convenient coefficient field: the +fields are constructed from a basis containing the supplied coordinate. -/ +theorem exists_relative_finite_tower + (k : Type u) [Field k] + {K : Type v} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + (x : K) (hx : Transcendental k x) : + ∃ (s : Set K) (E : IntermediateField k K) + (F : IntermediateField E K), + x ∈ s ∧ + IsTranscendenceBasis k ((↑) : s → K) ∧ + E = coefficientField k s x ∧ + F = IntermediateField.adjoin E ({x} : Set K) ∧ + F.restrictScalars k = IntermediateField.adjoin k s ∧ + Transcendental E x ∧ + x ∈ F ∧ + FiniteDimensional F K := by + obtain ⟨s, hxs, hs⟩ := exists_transcendenceBasis_containing k x hx + let E : IntermediateField k K := coefficientField k s x + let F : IntermediateField E K := IntermediateField.adjoin E ({x} : Set K) + have hF : F.restrictScalars k = IntermediateField.adjoin k s := by + exact restrictScalars_adjoin_coordinate k s x hxs + have hfinB : FiniteDimensional (IntermediateField.adjoin k s) K := + finiteDimensional_over_adjoin_transcendenceBasis k hfg hs + letI : FiniteDimensional (IntermediateField.adjoin k s) K := hfinB + -- `F` and `k(s)` have the same elements in `K`; use the induced inclusion + -- tower to transfer algebraicity and finite type to the relative field. + have hB_le_F : IntermediateField.adjoin k s ≤ F.restrictScalars k := hF.ge + letI : Algebra (IntermediateField.adjoin k s) F := + (IntermediateField.inclusion hB_le_F).toAlgebra + letI : IsScalarTower (IntermediateField.adjoin k s) F K := + IsScalarTower.of_algebraMap_eq (fun _ ↦ rfl) + haveI : Algebra.IsAlgebraic (IntermediateField.adjoin k s) K := + Algebra.IsAlgebraic.of_finite (IntermediateField.adjoin k s) K + haveI : Algebra.IsAlgebraic F K := + Algebra.IsAlgebraic.extendScalars + (IntermediateField.inclusion_injective hB_le_F) + letI : Algebra.FiniteType F K := + Algebra.FiniteType.of_restrictScalars_finiteType + (IntermediateField.adjoin k s) F K + letI : Algebra.IsIntegral F K := + ⟨fun y ↦ (Algebra.IsAlgebraic.isAlgebraic y).isIntegral⟩ + have hfinF : FiniteDimensional F K := Algebra.IsIntegral.finite + have hxE : Transcendental E x := + transcendental_over_coefficientField k hs hxs + refine ⟨s, E, F, hxs, hs, rfl, rfl, hF, hxE, ?_, hfinF⟩ + exact IntermediateField.subset_adjoin E ({x} : Set K) (Set.mem_singleton x) + +/-- In characteristic zero, the finite relative extension just constructed is +automatically separable. This closes the separability hypothesis required by +`DivisorialBoundaryExtension`. -/ +theorem exists_relative_finite_separable_tower_of_charZero + (k : Type u) [Field k] [CharZero k] + {K : Type v} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + (x : K) (hx : Transcendental k x) : + ∃ (s : Set K) (E : IntermediateField k K) + (F : IntermediateField E K), + x ∈ s ∧ + IsTranscendenceBasis k ((↑) : s → K) ∧ + E = coefficientField k s x ∧ + F = IntermediateField.adjoin E ({x} : Set K) ∧ + F.restrictScalars k = IntermediateField.adjoin k s ∧ + Transcendental E x ∧ + x ∈ F ∧ + FiniteDimensional F K ∧ + Algebra.IsSeparable F K := by + obtain ⟨s, E, F, hxs, hs, hE, hFdef, hFrestrict, hxE, hxF, hfin⟩ := + exists_relative_finite_tower k hfg x hx + letI : FiniteDimensional F K := hfin + letI : CharZero F := + charZero_of_injective_algebraMap (algebraMap k F).injective + letI : Algebra.IsIntegral F K := + ⟨fun y ↦ (IsAlgebraic.of_finite F y).isIntegral⟩ + let hsep : Algebra.IsSeparable F K := + Algebra.IsSeparable.of_integral F K + exact ⟨s, E, F, hxs, hs, hE, hFdef, hFrestrict, hxE, hxF, hfin, hsep⟩ + + +end + +end Stafford38.Geometry.RelativeDivisorialTower diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RelativeFractionFieldTransport.lean b/LeanPool/Stafford38/Stafford38/Geometry/RelativeFractionFieldTransport.lean new file mode 100644 index 0000000000..51ea1c5e5d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RelativeFractionFieldTransport.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.RelativeDivisorialTower +import LeanPool.Stafford38.Stafford38.Geometry.DivisorialBoundaryExtension +import Mathlib.RingTheory.AlgebraicIndependent.Adjoin +import Mathlib.RingTheory.Localization.LocalizationLocalization + +/-! +# Transport from a relative rational function field to the coordinate DVR + +This file identifies the fraction field of the coordinate-zero local ring +`E[X]_(X)` with the concrete simple transcendental field `E(x)`. The +equivalence is compatible with evaluation at `x`; it therefore transports the +finite separable tower constructed in `RelativeDivisorialTower` to the exact +input expected by `DivisorialBoundaryExtension`. +-/ + +namespace Stafford38.Geometry.RelativeFractionFieldTransport + +open Set +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.RelativeDivisorialTower +open Stafford38.Geometry.DivisorialBoundaryExtension + +noncomputable section + + +universe u v + +attribute [-instance] instAlgebraAtPrimeFractionRing + +/-- Evaluation at a transcendental element identifies the polynomial +fraction field with the concrete intermediate field generated by that +element. -/ +def polynomialFractionEquivAdjoin + (E : Type u) [Field E] + {K : Type v} [Field K] [Algebra E K] + (x : K) (hx : Transcendental E x) : + FractionRing (Polynomial E) ≃ₐ[E] + IntermediateField.adjoin E ({x} : Set K) := by + let g : Polynomial E →ₐ[E] K := Polynomial.aeval x + let i : FractionRing (Polynomial E) →ₐ[E] K := + IsFractionRing.liftAlgHom + (K := FractionRing (Polynomial E)) + (transcendental_iff_injective.mp hx) + exact (AlgEquiv.ofInjectiveField i).trans + (IntermediateField.equivOfEq + (IsFractionRing.liftAlgHom_fieldRange_eq_of_range_eq + (g := g) + (transcendental_iff_injective.mp hx) + (Algebra.adjoin_singleton_eq_range_aeval E x).symm)) + +@[simp] +theorem polynomialFractionEquivAdjoin_algebraMap + (E : Type u) [Field E] + {K : Type v} [Field K] [Algebra E K] + (x : K) (hx : Transcendental E x) (p : Polynomial E) : + ((polynomialFractionEquivAdjoin E x hx + (algebraMap (Polynomial E) (FractionRing (Polynomial E)) p) : + IntermediateField.adjoin E ({x} : Set K)) : K) = + Polynomial.aeval x p := by + let g : Polynomial E →+* K := (Polynomial.aeval x).toRingHom + change IsFractionRing.lift (K := FractionRing (Polynomial E)) + (transcendental_iff_injective.mp hx) + (algebraMap (Polynomial E) (FractionRing (Polynomial E)) p) = + Polynomial.aeval x p + exact IsFractionRing.lift_algebraMap + (transcendental_iff_injective.mp hx) p + +/-- Localizing `E[X]` away from `(X)` does not change its fraction field. +Composing that canonical comparison with transcendental evaluation realizes +the result as the concrete field `E(x)`. -/ +def coordinateLocalFractionEquivAdjoin + (E : Type u) [Field E] + {K : Type v} [Field K] [Algebra E K] + (x : K) (hx : Transcendental E x) : + FractionRing (CoordinateZeroLocalRing E) ≃ₐ[E] + IntermediateField.adjoin E ({x} : Set K) := by + letI : IsScalarTower E (CoordinateZeroLocalRing E) + (FractionRing (Polynomial E)) := + IsScalarTower.of_algebraMap_eq fun a => by + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (CoordinateZeroLocalRing E)] + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (FractionRing (Polynomial E))] + exact IsScalarTower.algebraMap_apply (Polynomial E) + (CoordinateZeroLocalRing E) (FractionRing (Polynomial E)) + (algebraMap E (Polynomial E) a) + let e₀ : FractionRing (CoordinateZeroLocalRing E) ≃ₐ[E] + FractionRing (Polynomial E) := + (FractionRing.algEquiv (CoordinateZeroLocalRing E) + (FractionRing (Polynomial E))).restrictScalars E + exact e₀.trans (polynomialFractionEquivAdjoin E x hx) + +/-- The fraction-field comparison sends the distinguished local coordinate +to the selected element `x`, not merely to an abstract generator. -/ +@[simp] +theorem coordinateLocalFractionEquivAdjoin_X + (E : Type u) [Field E] + {K : Type v} [Field K] [Algebra E K] + (x : K) (hx : Transcendental E x) : + let R := CoordinateZeroLocalRing E + let L := FractionRing R + (((coordinateLocalFractionEquivAdjoin E x hx + (algebraMap R L + (algebraMap (Polynomial E) R Polynomial.X)) : + IntermediateField.adjoin E ({x} : Set K)) : K)) = x := by + dsimp only + letI : IsScalarTower E (CoordinateZeroLocalRing E) + (FractionRing (Polynomial E)) := + IsScalarTower.of_algebraMap_eq fun a => by + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (CoordinateZeroLocalRing E)] + rw [IsScalarTower.algebraMap_apply E (Polynomial E) + (FractionRing (Polynomial E))] + exact IsScalarTower.algebraMap_apply (Polynomial E) + (CoordinateZeroLocalRing E) (FractionRing (Polynomial E)) + (algebraMap E (Polynomial E) a) + rw [coordinateLocalFractionEquivAdjoin, AlgEquiv.trans_apply] + change ↑((polynomialFractionEquivAdjoin E x hx) + ((FractionRing.algEquiv (CoordinateZeroLocalRing E) + (FractionRing (Polynomial E))) + ((algebraMap (CoordinateZeroLocalRing E) + (FractionRing (CoordinateZeroLocalRing E))) + ((algebraMap (Polynomial E) (CoordinateZeroLocalRing E)) + Polynomial.X)))) = x + rw [AlgEquiv.commutes] + rw [← IsScalarTower.algebraMap_apply (Polynomial E) + (CoordinateZeroLocalRing E) (FractionRing (Polynomial E))] + simpa only [Polynomial.aeval_X] using + polynomialFractionEquivAdjoin_algebraMap E x hx Polynomial.X + +/-- A finite separable extension of the concrete field `E(x)` gives the exact +fraction-field action needed by the coordinate DVR theorem. Both finiteness +and separability are transported across the displayed field equivalence; the +coordinate compatibility is discharged by +`coordinateLocalFractionEquivAdjoin_X`. -/ +theorem exists_discreteBoundaryRefinement_of_adjoin + (E : Type u) [Field E] + {K : Type v} [Field K] [Algebra E K] + (x : K) (hx : Transcendental E x) + (hfin : FiniteDimensional + (IntermediateField.adjoin E ({x} : Set K)) K) + (hsep : Algebra.IsSeparable + (IntermediateField.adjoin E ({x} : Set K)) K) : + ∃ V : ValuationSubring K, + IsDiscreteValuationRing V.toSubring ∧ + ∃ xV : V.toSubring, + (xV : K) = x ∧ xV ≠ 0 ∧ ¬IsUnit xV := by + let R := CoordinateZeroLocalRing E + let L := FractionRing R + let F := IntermediateField.adjoin E ({x} : Set K) + let e : L ≃ₐ[E] F := coordinateLocalFractionEquivAdjoin E x hx + letI : Algebra R F := + (e.toRingEquiv.toRingHom.comp (algebraMap R L)).toAlgebra + let eR : L ≃ₐ[R] F := + { e.toRingEquiv with + commutes' := fun _ => rfl } + letI : IsFractionRing R F := + IsLocalization.isLocalization_of_algEquiv (nonZeroDivisors R) eR + letI : Algebra R K := + ((algebraMap F K).comp (algebraMap R F)).toAlgebra + letI : IsScalarTower R F K := + IsScalarTower.of_algebraMap_eq fun _ => rfl + letI : FiniteDimensional F K := hfin + letI : Algebra.IsSeparable F K := hsep + let q : R := algebraMap (Polynomial E) R Polynomial.X + have hq_ne : q ≠ 0 := by + intro hq + apply Polynomial.X_ne_zero (R := E) + apply IsLocalization.injective R + (coordinateZeroPrime E).primeCompl_le_nonZeroDivisors + simpa only [q, map_zero] using hq + have hq_nonunit : ¬IsUnit q := by + rw [← mem_nonunits_iff, ← mem_maximalIdeal] + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff + R (coordinateZeroPrime E) Polynomial.X).2 + (Ideal.mem_span_singleton_self Polynomial.X) + have hcoordinate : algebraMap R K q = x := by + change (((e (algebraMap R L q) : F) : K)) = x + exact coordinateLocalFractionEquivAdjoin_X E x hx + obtain ⟨V, hV, qV, hqV, hqV_ne, hqV_nonunit⟩ := + exists_discreteValuationSubring_over_maximalIdeal + (A := R) (F := F) (L := K) q hq_ne hq_nonunit + exact ⟨V, hV, qV, hqV.trans hcoordinate, hqV_ne, hqV_nonunit⟩ + +/-- The relative tower constructed from a finitely generated characteristic- +zero function field therefore has an actual discrete boundary place above +the selected coordinate. -/ +theorem exists_discreteBoundaryRefinement_of_fg_charZero + (k : Type u) [Field k] [CharZero k] + {K : Type v} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + (x : K) (hx : Transcendental k x) : + ∃ V : ValuationSubring K, + IsDiscreteValuationRing V.toSubring ∧ + ∃ xV : V.toSubring, + (xV : K) = x ∧ xV ≠ 0 ∧ ¬IsUnit xV := by + obtain ⟨s, E, F, hxs, hs, hE, hF, hrestrict, hxE, hxF, + hfin, hsep⟩ := + exists_relative_finite_separable_tower_of_charZero k hfg x hx + subst F + exact exists_discreteBoundaryRefinement_of_adjoin + E x hxE hfin hsep + +/-- Structured form of the preceding theorem, ready for the downstream +projective order-gap consumer. -/ +theorem exists_discreteBoundaryRefinement_of_fg_charZero_structured + (k : Type u) [Field k] [CharZero k] + {K : Type v} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + (x : K) (hx : Transcendental k x) : + Nonempty (DiscreteBoundaryRefinement k x) := by + obtain ⟨V, hV, xV, hxV, hxV_ne, hxV_nonunit⟩ := + exists_discreteBoundaryRefinement_of_fg_charZero k hfg x hx + exact ⟨{ + valuation := V + isDiscrete := hV + coordinate := xV + coordinate_eq := hxV + coordinate_ne := hxV_ne + coordinate_nonunit := hxV_nonunit + }⟩ + + +attribute [instance] instAlgebraAtPrimeFractionRing + +end + +end Stafford38.Geometry.RelativeFractionFieldTransport diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RelativeRetainedBoundaryPlace.lean b/LeanPool/Stafford38/Stafford38/Geometry/RelativeRetainedBoundaryPlace.lean new file mode 100644 index 0000000000..f0bc5d7e1b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RelativeRetainedBoundaryPlace.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CompletedDVRPowerSeriesEquiv + +/-! +# Relative retained boundary places + +The divisorial construction for a transcendental element can retain the +actual local map from the coordinate DVR `E[X]_(X)`. This is stronger than +the bare `DiscreteBoundaryRefinement`: it preserves the coefficient field and +the algebra structure needed by the completed-DVR coefficient section. + +No projective normalization, completed projective coordinates, or tangent +frame is constructed here. +-/ + +namespace Stafford38.Geometry.RelativeRetainedBoundaryPlace + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CompletedDVRPowerSeries +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeDivisorialTower +open Stafford38.Geometry.RelativeFractionFieldTransport +open Stafford38.Geometry.RetainedDVR + +noncomputable section + + +universe u + +attribute [-instance] instAlgebraAtPrimeFractionRing + +private abbrev SourceDVR (E : Type u) [Field E] := + CoordinateZeroLocalRing E + +/-- A retained boundary place for `x`, including the relative coefficient +field and the exact ambient algebra structure under which the local +coordinate maps to `x`. -/ +structure Data + (k K : Type u) [Field k] [Field K] [Algebra k K] + (x : K) where + coefficientField : IntermediateField k K + coordinate_transcendental : Transcendental coefficientField x + ambientAlgebra : Algebra (SourceDVR coefficientField) K + coefficientTower : + letI : Algebra (SourceDVR coefficientField) K := ambientAlgebra + IsScalarTower coefficientField (SourceDVR coefficientField) K + coordinate_eq : + letI : Algebra (SourceDVR coefficientField) K := ambientAlgebra + algebraMap (SourceDVR coefficientField) K + (algebraMap (Polynomial coefficientField) + (SourceDVR coefficientField) Polynomial.X) = x + place : + letI : Algebra (SourceDVR coefficientField) K := ambientAlgebra + RetainedDVRPlace (SourceDVR coefficientField) (L := K) + (algebraMap (Polynomial coefficientField) + (SourceDVR coefficientField) Polynomial.X) + +/-- The retained parameter is the selected function-field coordinate. -/ +theorem Data.parameter_eq_coordinate + {k K : Type u} [Field k] [Field K] [Algebra k K] + {x : K} (W : Data k K x) : + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + (W.place.parameter : K) = x := by + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + exact W.place.parameter_eq.trans W.coordinate_eq + +/-- Forgetting the retained source map recovers the earlier discrete boundary +refinement, with the same valuation ring and parameter. -/ +def Data.toDiscreteBoundaryRefinement + {k K : Type u} [Field k] [Field K] [Algebra k K] + {x : K} (W : Data k K x) : + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + DiscreteBoundaryRefinement k x := by + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + exact { + valuation := W.place.valuation + isDiscrete := W.place.isDiscrete + coordinate := W.place.parameter + coordinate_eq := W.parameter_eq_coordinate + coordinate_ne := W.place.parameter_ne + coordinate_nonunit := W.place.parameter_nonunit + } + +/-- The completion of the retained component DVR is literally a power-series +ring over its residue field. This is the completion, not the original DVR. -/ +def Data.completedPowerSeriesEquiv + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] + {x : K} (W : Data k K x) : + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + PowerSeries (ResidueField V) ≃+* + AdicCompletion (IsLocalRing.maximalIdeal V) V := by + letI : Algebra (SourceDVR W.coefficientField) K := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact completedDVRPowerSeriesEquivOfSurjective W.coefficientField + V + (relativeResidue_isSeparable W.coefficientField W.place) + (completedDVRPowerSeriesMap_surjective W.coefficientField + V + (relativeResidue_isSeparable W.coefficientField W.place)) + +/-- A finitely generated characteristic-zero function field and a selected +transcendental element admit a retained relative boundary place. -/ +theorem exists_data_of_fg_charZero + (k : Type u) [Field k] [CharZero k] + {K : Type u} [Field K] [Algebra k K] + (hfg : (⊤ : IntermediateField k K).FG) + (x : K) (hx : Transcendental k x) : + Nonempty (Data k K x) := by + obtain ⟨s, E, F, hxs, hs, hE, hF, hrestrict, hxE, hxF, + hfin, hsep⟩ := + exists_relative_finite_separable_tower_of_charZero k hfg x hx + subst F + let R := SourceDVR E + let L := FractionRing R + let F := IntermediateField.adjoin E ({x} : Set K) + let e : L ≃ₐ[E] F := coordinateLocalFractionEquivAdjoin E x hxE + letI : IsScalarTower E R L := + IsScalarTower.of_algebraMap_eq fun _ => rfl + let algRF : Algebra R F := + (e.toRingEquiv.toRingHom.comp (algebraMap R L)).toAlgebra + letI : Algebra R F := algRF + let towerERF : IsScalarTower E R F := + IsScalarTower.of_algebraMap_eq fun a => by + change algebraMap E F a = e (algebraMap R L (algebraMap E R a)) + rw [← IsScalarTower.algebraMap_apply E R L] + exact (e.commutes a).symm + letI : IsScalarTower E R F := towerERF + let eR : L ≃ₐ[R] F := + { e.toRingEquiv with + commutes' := fun _ => rfl } + letI : IsFractionRing R F := + IsLocalization.isLocalization_of_algEquiv (nonZeroDivisors R) eR + let algRK : Algebra R K := + ((algebraMap F K).comp (algebraMap R F)).toAlgebra + letI : Algebra R K := algRK + let coefficientTower : IsScalarTower E R K := + IsScalarTower.of_algebraMap_eq fun a => by + change algebraMap E K a = + algebraMap F K (algebraMap R F (algebraMap E R a)) + rw [← IsScalarTower.algebraMap_apply E R F] + exact IsScalarTower.algebraMap_apply E F K a + letI : IsScalarTower E R K := coefficientTower + letI : IsScalarTower R F K := + IsScalarTower.of_algebraMap_eq fun _ => rfl + letI : FiniteDimensional F K := hfin + letI : Algebra.IsSeparable F K := hsep + let q : R := algebraMap (Polynomial E) R Polynomial.X + have hq_ne : q ≠ 0 := by + intro hq + apply Polynomial.X_ne_zero (R := E) + apply IsLocalization.injective R + (coordinateZeroPrime E).primeCompl_le_nonZeroDivisors + simpa only [q, map_zero] using hq + have hq_nonunit : ¬IsUnit q := by + rw [← mem_nonunits_iff, ← mem_maximalIdeal] + exact (IsLocalization.AtPrime.to_map_mem_maximal_iff + R (coordinateZeroPrime E) Polynomial.X).2 + (Ideal.mem_span_singleton_self Polynomial.X) + have hcoordinate : algebraMap R K q = x := by + change (((e (algebraMap R L q) : F) : K)) = x + exact coordinateLocalFractionEquivAdjoin_X E x hxE + obtain ⟨D⟩ := + exists_retainedDVRPlace (A := R) (F := F) (L := K) + q hq_ne hq_nonunit + exact ⟨{ + coefficientField := E + coordinate_transcendental := hxE + ambientAlgebra := algRK + coefficientTower := coefficientTower + coordinate_eq := hcoordinate + place := D + }⟩ + + +attribute [instance] instAlgebraAtPrimeFractionRing + +end + +end Stafford38.Geometry.RelativeRetainedBoundaryPlace diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ResidueMinorSelection.lean b/LeanPool/Stafford38/Stafford38/Geometry/ResidueMinorSelection.lean new file mode 100644 index 0000000000..b6caf9f36b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ResidueMinorSelection.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.SplitTangentMatrix +import Mathlib.LinearAlgebra.Matrix.Rank +import Mathlib.LinearAlgebra.Basis.VectorSpace + +/-! +# Selecting a nonsingular residue minor + +A rectangular matrix over a field with full column rank has a square row minor +with nonzero determinant. The selected rows are returned as an embedding of +the column index type into the row index type, matching the input expected by +`GeometrySplitTangentMatrix`. +-/ + +namespace Stafford38.GeometryResidueMinorSelection + +noncomputable section + +open Stafford38.GeometrySplitTangentMatrix + +universe u v w + +variable {k : Type u} [Field k] + +/-- Full column rank produces an explicitly indexed square row minor with +nonzero determinant. -/ +theorem exists_selectedMinor_det_ne_zero_of_rank_eq_card + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ k) (hrank : B.rank = Fintype.card κ) : + ∃ rows : κ ↪ ι, (selectedMinor B rows).det ≠ 0 := by + let S : Submodule k (κ → k) := Submodule.span k (Set.range B.row) + have hfinrank : Module.finrank k S = Module.finrank k (κ → k) := by + rw [← Matrix.rank_eq_finrank_span_row B, hrank, Module.finrank_pi] + have hS : S = ⊤ := Submodule.eq_top_of_finrank_eq hfinrank + let b := Module.Basis.ofSpan (K := k) (s := Set.range B.row) (hS.ge) + letI : Fintype ((linearIndepOn_empty k id).extend + (Set.empty_subset (Set.range B.row))) := Fintype.ofFinite _ + let e : κ ≃ ((linearIndepOn_empty k id).extend + (Set.empty_subset (Set.range B.row))) := + Fintype.equivOfCardEq (by + rw [← Module.finrank_eq_card_basis b, Module.finrank_pi]) + have hb_range (a : κ) : b (e a) ∈ Set.range B := + Module.Basis.ofSpan_subset (K := k) (V := κ → k) (hS.ge) ⟨e a, rfl⟩ + let row (a : κ) : ι := Classical.choose (hb_range a) + have hrow (a : κ) : B (row a) = b (e a) := Classical.choose_spec (hb_range a) + have hrow_injective : Function.Injective row := by + intro a₁ a₂ h + apply e.injective + apply b.injective + rw [← hrow a₁, ← hrow a₂, h] + let rows : κ ↪ ι := ⟨row, hrow_injective⟩ + have hli : LinearIndependent k (fun a : κ => selectedMinor B rows a) := by + have he : LinearIndependent k (fun a : κ => b (e a)) := + b.linearIndependent.comp _ e.injective + have hfamily : (fun a : κ => selectedMinor B rows a) = fun a => b (e a) := by + funext a + exact hrow a + rw [hfamily] + exact he + have hunit : IsUnit (selectedMinor B rows) := + Matrix.linearIndependent_rows_iff_isUnit.mp hli + exact ⟨rows, ((Matrix.isUnit_iff_isUnit_det _).mp hunit).ne_zero⟩ + +/-- Injectivity of the residue matrix on column vectors is the usual +hypothesis implying the existence of a nonsingular selected row minor. -/ +theorem exists_selectedMinor_det_ne_zero_of_mulVec_injective + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ k) (hinj : Function.Injective B.mulVec) : + ∃ rows : κ ↪ ι, (selectedMinor B rows).det ≠ 0 := by + apply exists_selectedMinor_det_ne_zero_of_rank_eq_card B + have hker : LinearMap.ker B.mulVecLin = ⊥ := LinearMap.ker_eq_bot.mpr hinj + have hker_finrank : Module.finrank k (LinearMap.ker B.mulVecLin) = 0 := by + rw [hker] + exact finrank_bot k (κ → k) + have hrn := LinearMap.finrank_range_add_finrank_ker B.mulVecLin + rw [hker_finrank, add_zero, Module.finrank_pi] at hrn + simpa only [Matrix.rank] using hrn + +/-! ## Power-series residue matrices -/ + +/-- Entrywise constant coefficient of a power-series matrix. -/ +def residueMatrix + {ι : Type v} {κ : Type w} (B : Matrix ι κ (PowerSeries k)) : Matrix ι κ k := + fun i j => PowerSeries.constantCoeff (B i j) + +theorem constantCoeff_selectedMinor_det + {ι : Type v} {κ : Type w} [Fintype κ] [DecidableEq κ] + (B : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) : + PowerSeries.constantCoeff (selectedMinor B rows).det = + (selectedMinor (residueMatrix B) rows).det := by + rw [RingHom.map_det] + congr 1 + +/-- Injectivity after reduction to constant coefficients selects a minor whose +power-series determinant is a unit. -/ +theorem powerSeries_exists_selectedMinor_constantCoeff_ne_zero_of_residue_mulVec_injective + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ (PowerSeries k)) + (hinj : Function.Injective (residueMatrix B).mulVec) : + ∃ rows : κ ↪ ι, + PowerSeries.constantCoeff (selectedMinor B rows).det ≠ 0 := by + obtain ⟨rows, hrows⟩ := + exists_selectedMinor_det_ne_zero_of_mulVec_injective (residueMatrix B) hinj + exact ⟨rows, by rwa [constantCoeff_selectedMinor_det]⟩ + +/-- The residue-rank criterion composed with the selected-minor construction: +the power-series matrix has an explicit left inverse. -/ +theorem powerSeries_exists_leftInverse_of_residue_mulVec_injective + {ι : Type v} {κ : Type w} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ (PowerSeries k)) + (hinj : Function.Injective (residueMatrix B).mulVec) : + ∃ C : Matrix κ ι (PowerSeries k), C * B = 1 := by + obtain ⟨rows, hrows⟩ := + powerSeries_exists_selectedMinor_constantCoeff_ne_zero_of_residue_mulVec_injective B hinj + exact powerSeries_exists_leftInverse_of_selectedMinor_constantCoeff_ne_zero B rows hrows + + +end + +end Stafford38.GeometryResidueMinorSelection diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetainedComponentEquationPackage.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetainedComponentEquationPackage.lean new file mode 100644 index 0000000000..d865a6a9f1 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetainedComponentEquationPackage.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosureNormalization + +/-! +# Finite retained component equations + +A finite generating family of an affine ideal contained in a prime component +is homogenized over the ground field and then transported through the explicit +retained Laurent coefficient map. The resulting homogeneous equations vanish +on every retained common-scale completion, and their zeroth-chart +dehomogenizations generate exactly the scalar-extended affine ideal. + +No ambient algebra structure on the residue field is used, and no tangent data +are constructed here. +-/ + +namespace Stafford38.Geometry.RetainedComponentEquationPackage + +open IsLocalRing +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveClosureNormalization +open Stafford38.Geometry.LocalizedProjectiveChartTransition +open Stafford38.Geometry.ProjectiveEquationFormalChart +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedProjectiveCompletion + +noncomputable section + +-- The single theorem below carries a tower of `letI` instances in its +-- statement and elaborates just past the previous 10000000 limit under Lean +-- 4.33. Measured cost at this limit: about 2m40s for the file. Heartbeats +-- are a deterministic step count, so this bound is machine-independent and is +-- kept snug deliberately, to stay a regression tripwire. + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- Mapping coefficients commutes with zeroth-chart dehomogenization. -/ +theorem projectiveDehomogenize_map + {S : Type u} [Field S] (coeff : k →+* S) + (H : MvPolynomial (Fin (m + 1)) k) : + projectiveDehomogenize (n := m) + (MvPolynomial.map coeff H) = + MvPolynomial.map coeff (projectiveDehomogenize H) := by + change MvPolynomial.bind₁ (Fin.cases 1 fun j ↦ MvPolynomial.X j) + (MvPolynomial.map coeff H) = + MvPolynomial.map coeff + (MvPolynomial.bind₁ (Fin.cases 1 fun j ↦ MvPolynomial.X j) H) + rw [MvPolynomial.map_bind₁] + apply congrArg (fun g ↦ + MvPolynomial.bind₁ g (MvPolynomial.map coeff H)) + funext a + refine Fin.cases ?_ (fun j ↦ ?_) a <;> simp + +/-- Mapping coefficients therefore commutes with dehomogenizing the standard +ground-field homogenization. -/ +theorem projectiveDehomogenize_map_homogenizeAtZero + {S : Type u} [Field S] (coeff : k →+* S) + (f : MvPolynomial (Fin m) k) : + projectiveDehomogenize (n := m) + (MvPolynomial.map coeff (homogenizeAtZero f)) = + MvPolynomial.map coeff f := by + rw [projectiveDehomogenize_map, + projectiveDehomogenize_homogenizeAtZero] + +/-- The mapped homogenizations of a finite family dehomogenize to precisely +the mapped ideal spanned by that family. -/ +theorem dehomogenizedEquationIdeal_mapped_homogenizations + {S : Type u} [Field S] (coeff : k →+* S) {r : ℕ} + (generators : Fin r → MvPolynomial (Fin m) k) : + dehomogenizedEquationIdeal + (fun j ↦ MvPolynomial.map coeff + (homogenizeAtZero (generators j))) = + (Ideal.span (Set.range generators)).map (MvPolynomial.map coeff) := by + rw [dehomogenizedEquationIdeal] + simp_rw [projectiveDehomogenize_map_homogenizeAtZero coeff] + rw [Ideal.map_span] + congr 1 + ext x + constructor + · rintro ⟨j, rfl⟩ + exact ⟨generators j, ⟨j, rfl⟩, rfl⟩ + · rintro ⟨_, ⟨j, rfl⟩, rfl⟩ + exact ⟨j, rfl⟩ + +/-- A finite homogeneous equation package over a displayed coefficient map. +Its last field records exact generation, not merely containment. -/ +structure EquationPackage + {S : Type u} [Field S] + (I : Ideal (MvPolynomial (Fin m) k)) (coeff : k →+* S) + (q : Fin (m + 1) → S) where + equationCount : ℕ + equations : Fin equationCount → MvPolynomial (Fin (m + 1)) S + degree : Fin equationCount → ℕ + homogeneous : ∀ j, (equations j).IsHomogeneous (degree j) + equations_vanish : ∀ j, MvPolynomial.eval q (equations j) = 0 + dehomogenizedEquationIdeal_eq : + dehomogenizedEquationIdeal equations = + I.map (MvPolynomial.map coeff) + +/-- Exact finite equation package obtained from ground-field generators of +`I`. The coefficient map in both the equations and the ideal equality is the +displayed retained Laurent coefficient map. -/ +theorem retainedComponentEquationPackage + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (I : Ideal (MvPolynomial (Fin m) k)) (hIP : I ≤ P.asIdeal) + (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + Nonempty (EquationPackage I + (retainedLaurentCoefficientMap P i W) + (fun a ↦ algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W (q a)))) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro q scale hq + obtain ⟨r, generators, hgenerators⟩ := + Submodule.fg_iff_exists_fin_generating_family.mp + (IsNoetherian.noetherian (I : Submodule _ _)) + let coeff : k →+* LaurentSeries (ResidueField V) := + retainedLaurentCoefficientMap P i W + let equations : Fin r → + MvPolynomial (Fin (m + 1)) (LaurentSeries (ResidueField V)) := + fun j ↦ MvPolynomial.map coeff + (homogenizeAtZero (generators j)) + let degree : Fin r → ℕ := + fun j ↦ (generators j).totalDegree + have hgenerator_mem : ∀ j, generators j ∈ I := by + intro j + rw [← hgenerators] + exact Submodule.subset_span (Set.mem_range_self j) + refine ⟨{ + equationCount := r + equations := equations + degree := degree + homogeneous := ?_ + equations_vanish := ?_ + dehomogenizedEquationIdeal_eq := ?_ }⟩ + · intro j + exact (homogenizeAtZero_isHomogeneous + (generators j)).map coeff + · intro j + change MvPolynomial.eval _ + (MvPolynomial.map coeff + (homogenizeAtZero + (generators j))) = 0 + rw [MvPolynomial.eval_map] + exact retainedLaurent_eval₂_eq_zero_of_commonScale P i W + (homogenizeAtZero_isHomogeneous + (generators j)) + (homogenizeAtZero_mem_componentProjectiveClosureIdeal P + (hIP (hgenerator_mem j))) q scale hq + · change dehomogenizedEquationIdeal + (fun j ↦ MvPolynomial.map coeff + (homogenizeAtZero (generators j))) = + I.map (MvPolynomial.map coeff) + rw [dehomogenizedEquationIdeal_mapped_homogenizations] + change Ideal.map (MvPolynomial.map coeff) + (Submodule.span _ (Set.range generators)) = + I.map (MvPolynomial.map coeff) + rw [hgenerators] + + +end + +end Stafford38.Geometry.RetainedComponentEquationPackage diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetainedDVRPlace.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetainedDVRPlace.lean new file mode 100644 index 0000000000..fef655abf2 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetainedDVRPlace.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.RelativeFractionFieldTransport +import Mathlib.RingTheory.LocalRing.ResidueField.Ideal +import Mathlib.RingTheory.Polynomial.Quotient +import Mathlib.RingTheory.Trace.Quotient + +/-! +# A retained source-DVR place + +This file retains the local map from the source DVR in the divisorial +construction and proves finiteness of the induced residue extension. It does +not construct a relative coefficient-field map, residue separability, an +inverse limit, or a power-series chart. +-/ + +namespace Stafford38.Geometry.RetainedDVR + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.RelativeDivisorialTower +open Stafford38.Geometry.RelativeFractionFieldTransport + +noncomputable section + + +universe u v w + +def ResidueExtensionFinite + {A V : Type*} [CommRing A] [IsLocalRing A] + [CommRing V] [IsLocalRing V] (factor : A →+* V) + (hlocal : IsLocalHom factor) : Prop := by + letI : Algebra A V := factor.toAlgebra + letI : IsLocalHom (algebraMap A V) := hlocal + exact Module.Finite (ResidueField A) (ResidueField V) + +/-- A divisorial place retaining its local source-DVR map. -/ +structure RetainedDVRPlace + (A : Type u) [CommRing A] [IsDomain A] [IsLocalRing A] + {L : Type w} [Field L] [Algebra A L] (a : A) where + valuation : ValuationSubring L + isDiscrete : IsDiscreteValuationRing valuation.toSubring + parameter : valuation.toSubring + parameter_eq : (parameter : L) = algebraMap A L a + parameter_ne : parameter ≠ 0 + parameter_nonunit : ¬IsUnit parameter + factor : A →+* valuation.toSubring + factor_commutes : + valuation.toSubring.subtype.comp factor = algebraMap A L + factor_isLocal : IsLocalHom factor + residue_finite : ResidueExtensionFinite factor factor_isLocal + +/-- Localization at the lying-over prime retains a local map from the source +DVR, and its residue field is finite over the source residue field. -/ +theorem exists_retainedDVRPlace + {A : Type u} {F : Type v} {L : Type w} + [CommRing A] [IsDomain A] [IsDiscreteValuationRing A] + [Field F] [Algebra A F] [IsFractionRing A F] + [Field L] [Algebra A L] [Algebra F L] [IsScalarTower A F L] + [FiniteDimensional F L] [Algebra.IsSeparable F L] + (a : A) (ha_ne : a ≠ 0) (ha_nonunit : ¬IsUnit a) : + Nonempty (RetainedDVRPlace A (L := L) a) := by + let C : Type w := integralClosure A L + letI : IsDedekindDomain C := integralClosure.isDedekindDomain A F L + letI : IsFractionRing C L := + IsIntegralClosure.isFractionRing_of_finite_extension A F L C + have hinjAL : Function.Injective (algebraMap A L) := by + rw [IsScalarTower.algebraMap_eq A F L] + exact (algebraMap F L).injective.comp (IsFractionRing.injective A F) + have hinjAC : Function.Injective (algebraMap A C) := by + intro x y hxy + apply hinjAL + calc + algebraMap A L x = algebraMap C L (algebraMap A C x) := + (IsScalarTower.algebraMap_apply A C L x).symm + _ = algebraMap C L (algebraMap A C y) := congrArg (algebraMap C L) hxy + _ = algebraMap A L y := IsScalarTower.algebraMap_apply A C L y + let m := maximalIdeal A + have hm_ne : m ≠ ⊥ := IsDiscreteValuationRing.not_a_field A + letI : m.IsPrime := (maximalIdeal.isMaximal A).isPrime + have hker : RingHom.ker (algebraMap A C) ≤ m := by + rw [(RingHom.injective_iff_ker_eq_bot _).mp hinjAC] + exact bot_le + obtain ⟨Q, hQprime, hQcomap⟩ := + Ideal.exists_ideal_over_prime_of_isIntegral_of_isDomain + (R := A) (S := C) m hker + letI : Q.IsPrime := hQprime + have hQ_ne : Q ≠ ⊥ := by + intro hQ + apply hm_ne + calc + m = Q.comap (algebraMap A C) := hQcomap.symm + _ = (⊥ : Ideal C).comap (algebraMap A C) := by rw [hQ] + _ = RingHom.ker (algebraMap A C) := + (RingHom.ker_eq_comap_bot (algebraMap A C)).symm + _ = ⊥ := (RingHom.injective_iff_ker_eq_bot _).mp hinjAC + have hQmax : Q.IsMaximal := by + apply Ideal.isMaximal_of_isIntegral_of_isMaximal_comap + (R := A) (S := C) Q + rw [hQcomap] + exact maximalIdeal.isMaximal A + letI : Q.IsMaximal := hQmax + let RQ : Type w := Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors + letI : IsDiscreteValuationRing RQ := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + C hQ_ne RQ + let Rsub : Subring L := + (Localization.subalgebra.ofField L Q.primeCompl + Q.primeCompl_le_nonZeroDivisors).toSubring + have hmem : ∀ y : L, y ∈ Rsub ∨ y⁻¹ ∈ Rsub := by + intro y + obtain ⟨r, hr | hr⟩ := + (ValuationRing.isFractionRing_iff.mp + (inferInstance : IsFractionRing RQ L)).1 y + · left; rw [hr]; exact r.property + · right; rw [hr]; exact r.property + let V : ValuationSubring L := ValuationSubring.ofSubring Rsub hmem + have hVdvr : IsDiscreteValuationRing V.toSubring := by + change IsDiscreteValuationRing RQ + infer_instance + letI : IsScalarTower A C RQ := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + letI : IsScalarTower A RQ L := + IsScalarTower.of_algebraMap_eq fun _ ↦ rfl + let factor : A →+* RQ := algebraMap A RQ + have hfactor : V.toSubring.subtype.comp factor = algebraMap A L := by + ext r + exact IsScalarTower.algebraMap_apply A RQ L r + have hfactorLocal : IsLocalHom factor := by + refine ⟨fun r hr ↦ ?_⟩ + by_contra hru + have hrm : r ∈ m := by + rw [mem_maximalIdeal] + exact hru + have hfactor_mem : factor r ∈ maximalIdeal RQ := by + change algebraMap C RQ (algebraMap A C r) ∈ maximalIdeal RQ + rw [IsLocalization.AtPrime.to_map_mem_maximal_iff RQ Q] + change r ∈ Q.comap (algebraMap A C) + rw [hQcomap] + exact hrm + exact (mem_nonunits_iff.mp hfactor_mem) hr + let aC : C := algebraMap A C a + have haC_mem : aC ∈ Q := by + have ha : a ∈ Q.comap (algebraMap A C) := by + rw [hQcomap, mem_maximalIdeal] + exact ha_nonunit + simpa only [Ideal.mem_comap, aC] using ha + let aRQ : RQ := algebraMap C RQ aC + have haRQ_mem : aRQ ∈ maximalIdeal RQ := + (IsLocalization.AtPrime.to_map_mem_maximal_iff RQ Q aC).2 haC_mem + have haRQ_nonunit : ¬IsUnit aRQ := mem_nonunits_iff.mp haRQ_mem + have haRQ_eq : (aRQ : L) = algebraMap A L a := by + change algebraMap C L (algebraMap A C a) = algebraMap A L a + exact IsScalarTower.algebraMap_apply A C L a + have haRQ_ne : aRQ ≠ 0 := by + intro ha0 + apply ha_ne + apply hinjAL + calc + algebraMap A L a = (aRQ : L) := haRQ_eq.symm + _ = ((0 : RQ) : L) := congrArg ((↑) : RQ → L) ha0 + _ = algebraMap A L 0 := by simp + letI : Algebra A RQ := factor.toAlgebra + letI : IsLocalHom (algebraMap A RQ) := hfactorLocal + letI : IsNoetherian A C := IsIntegralClosure.isNoetherian A F L C + letI : Module.Finite A C := inferInstance + letI : Q.LiesOver m := ⟨hQcomap.symm⟩ + letI : Module.Finite (A ⧸ m) (C ⧸ Q) := inferInstance + let sourceResidue : (A ⧸ m) ≃+* ResidueField A := + (Ideal.quotEquivOfEq (@IsLocalRing.ker_residue A _ _).symm).trans + (RingHom.quotientKerEquivOfSurjective + (f := residue A) residue_surjective) + let targetResidue : (C ⧸ Q) ≃+* ResidueField RQ := + (IsLocalization.AtPrime.equivQuotMaximalIdeal Q RQ).trans + ((Ideal.quotEquivOfEq (@IsLocalRing.ker_residue RQ _ _).symm).trans + (RingHom.quotientKerEquivOfSurjective + (f := residue RQ) residue_surjective)) + have hcompat : + RingHom.comp (algebraMap (ResidueField A) (ResidueField RQ)) + sourceResidue.toRingHom = + RingHom.comp targetResidue.toRingHom + (algebraMap (A ⧸ m) (C ⧸ Q)) := by + ext r + change residue RQ (factor r) = residue RQ (factor r) + rfl + have hfinite : Module.Finite (ResidueField A) (ResidueField RQ) := + Module.Finite.of_equiv_equiv sourceResidue targetResidue hcompat + exact ⟨{ + valuation := V + isDiscrete := hVdvr + parameter := aRQ + parameter_eq := haRQ_eq + parameter_ne := haRQ_ne + parameter_nonunit := haRQ_nonunit + factor := factor + factor_commutes := hfactor + factor_isLocal := hfactorLocal + residue_finite := hfinite + }⟩ + +end + +end Stafford38.Geometry.RetainedDVR diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetainedGroundMapIdentification.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetainedGroundMapIdentification.lean new file mode 100644 index 0000000000..beb23d5d60 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetainedGroundMapIdentification.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ComponentProjectiveClosureNormalization +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalResidueExtension +import LeanPool.Stafford38.Stafford38.Geometry.RetainedComponentEquationPackage + +/-! +# Ground coefficients in the retained completed chart + +The retained DVR construction carries a canonical ground-field map into its +residue field. With that map chosen as the `Algebra` structure, the explicit +coefficient map obtained by passing through the valuation ring, its completion, +and Laurent series is exactly the ground map used by the terminal geometric +consumer. + +The choice of `Algebra` structure is part of the statement. No equality with +an unrelated ground-field embedding of the residue field is asserted. +-/ + +namespace Stafford38.Geometry.RetainedGroundMapIdentification + +open IsLocalRing +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveClosureNormalization +open Stafford38.Geometry.CompletedDVRCoefficientSection +open Stafford38.Geometry.CompletedDVRPowerSeries +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedComponentEquationPackage +open Stafford38.Geometry.RetainedProjectiveCompletion + +noncomputable section + + +universe u + +variable {k : Type u} [Field k] {m : ℕ} + +/-- The ground-field structure on the retained residue field induced by the +actual coefficient map through the valuation ring. -/ +def retainedResidueGroundAlgebra + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + Algebra k (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact ((residue V).comp (retainedComponentCoefficientMap P i W)).toAlgebra + +/-- Ground coefficients transported through the retained valuation ring become +the corresponding constant power series for the induced residue-field map. -/ +theorem retainedToCompletedPowerSeries_ground + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + ∀ c : k, + retainedToCompletedPowerSeries W + (retainedComponentCoefficientMap P i W c) = + PowerSeries.C (R := ResidueField V) + (algebraMap k (ResidueField V) c) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + dsimp only + intro c + change W.completedPowerSeriesEquiv.symm + (algebraMap V (AdicCompletion (maximalIdeal V) V) + (relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c))) = _ + apply W.completedPowerSeriesEquiv.toEquiv.symm_apply_eq.mpr + change algebraMap V (AdicCompletion (maximalIdeal V) V) + (relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c)) = + completedDVRPowerSeriesMap W.coefficientField V + (relativeResidue_isSeparable W.coefficientField W.place) + (PowerSeries.C (R := ResidueField V) + (residue V + (relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c)))) + rw [completedDVRPowerSeriesMap_C] + change algebraMap V (AdicCompletion (maximalIdeal V) V) + (algebraMap W.coefficientField V + (algebraMap k W.coefficientField c)) = + completedCoefficientSection W.coefficientField V + (relativeResidue_isSeparable W.coefficientField W.place) + (algebraMap W.coefficientField (ResidueField V) + (algebraMap k W.coefficientField c)) + calc + algebraMap V (AdicCompletion (maximalIdeal V) V) + (algebraMap W.coefficientField V + (algebraMap k W.coefficientField c)) = + algebraMap W.coefficientField + (AdicCompletion (maximalIdeal V) V) + (algebraMap k W.coefficientField c) := + IsScalarTower.algebraMap_apply W.coefficientField V + (AdicCompletion (maximalIdeal V) V) + (algebraMap k W.coefficientField c) + _ = completedCoefficientSection W.coefficientField V + (relativeResidue_isSeparable W.coefficientField W.place) + (algebraMap W.coefficientField (ResidueField V) + (algebraMap k W.coefficientField c)) := + ((completedCoefficientSection W.coefficientField V + (relativeResidue_isSeparable W.coefficientField W.place)).commutes + (algebraMap k W.coefficientField c)).symm + +/-- With the residue-induced `Algebra` structure, the explicit retained +Laurent coefficient map is definitionally the terminal consumer's ground map. -/ +theorem retainedLaurentCoefficientMap_eq_groundLaurentMap + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + retainedLaurentCoefficientMap P i W = + groundLaurentMap (k := k) (K := ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + apply RingHom.ext + intro c + change algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W + (retainedComponentCoefficientMap P i W c)) = + algebraMap (ResidueField V) (LaurentSeries (ResidueField V)) + (algebraMap k (ResidueField V) c) + rw [retainedToCompletedPowerSeries_ground P i W] + rfl + +/-- The finite retained equation package therefore has exactly the coefficient +map required by the terminal residue-extension chart consumer. -/ +theorem retainedComponentGroundEquationPackage + [CharZero k] + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (I : Ideal (MvPolynomial (Fin m) k)) (hIP : I ≤ P.asIdeal) + (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + Nonempty (EquationPackage I + (groundLaurentMap (k := k) (K := ResidueField V)) + (fun a ↦ algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W (q a)))) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + dsimp only + intro q scale hq + simpa only [retainedLaurentCoefficientMap_eq_groundLaurentMap P i W] using + (retainedComponentEquationPackage P I hIP i W q scale hq) + + +end + +end Stafford38.Geometry.RetainedGroundMapIdentification diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetainedPlaceConormalTransport.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetainedPlaceConormalTransport.lean new file mode 100644 index 0000000000..dd47c977b7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetainedPlaceConormalTransport.lean @@ -0,0 +1,603 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof +import LeanPool.Stafford38.Stafford38.Geometry.DivisorTangentLattice +import LeanPool.Stafford38.Stafford38.Geometry.RetainedGroundMapIdentification + +/-! +# Transport of a divisor-tangent conormal row to the completed chart + +Let `P` be a prime component of affine `m`-space, `F` its function field, +`W` a retained boundary place for a transcendental component coordinate, +`V` its valuation ring and `Kres` its residue field. Given + +* normalized projective coordinates `q : Fin (m + 1) → V` of the generic + point (the output of + `exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace`), +* a visible divisor frame `D` on those coordinates (the input of the + divisor-tangent lattice lemma), and +* the generic-point Kähler bridge `hbridge` (a relation in `Ω[F⁄k]` among + the differentials of the coordinates yields an equation-defined conormal + covector over `F`; proved in a sibling file and taken here as an explicit + hypothesis), + +this file produces the `RegularizedOneRowConormalData` consumed by +`CanonicalNonconstantFiniteGradientProductionProof`, with the residue field +carrying the residue-induced ground structure +`retainedResidueGroundAlgebra`. + +What is proved (all trust-zero, no axioms beyond the standard three): + +1. `divisorFrame_kaehler_relation`: the lattice lemma gives a covector + `xi = e₀ - ∑ c_j e_j` with `c_j ∈ V` and `∑ xi_i • d y_i = 0`. +2. `coordinateCovector_map_mem_affineConormalSpace`: equation-defined + conormal membership transports along any ring homomorphism of fields. +3. `retainedLaurentLift`: the ring homomorphism `F →+* LaurentSeries Kres` + extending the retained completion, with its ground identification + `retainedLaurentLift_algebraMap_ground`. +4. `retainedLaurentLift_componentCoordinate`: the transported generic point + is the dehomogenized completed projective column. +5. `annihilation_identity`: the exact `V`-identity giving the projective + annihilation row. +6. `regularizedOneRowConormalData_of_transport`: the assembly over an + abstract local ring `V ⊆ F` with an injective completion map killing the + residue of nonunits and a compatible Laurent lift of `F`. +7. `exists_regularizedOneRowConormalData`: the instantiation at a retained + boundary place; the residue field carries `retainedResidueGroundAlgebra`. + +What is not proved here: the existence of a visible divisor frame `D`, and +the bridge `hbridge`; both are explicit hypotheses. +-/ + +namespace Stafford38.Geometry.RetainedPlaceConormalTransport + +open IsLocalRing +open Stafford38.Geometry.AffineComponentCoordinateSplit +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.CanonicalNonconstantFiniteGradientProductionProof +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.Geometry.ComponentFunctionFieldBoundary +open Stafford38.Geometry.ComponentProjectiveClosure +open Stafford38.Geometry.ComponentProjectiveClosureNormalization +open Stafford38.Geometry.DivisorTangentLattice +open Stafford38.Geometry.FiniteGradientFromTangentInclusion +open Stafford38.Geometry.FormalDivisorLaurentConormal +open Stafford38.Geometry.LaurentConormalResidueExtension +open Stafford38.Geometry.ProjectiveConormalDehomogenization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace +open Stafford38.Geometry.RetainedGroundMapIdentification +open Stafford38.Geometry.RetainedProjectiveCompletion +open Stafford38.GeometryRetractionSpecialization + +noncomputable section + + +universe u v + +/-! ## Generic algebra: covector transport along a ring homomorphism -/ + +section CovectorTransport + +variable {F L : Type*} [Field F] [Field L] {n : ℕ} + +/-- `differentialAt` commutes with coefficient transport. -/ +theorem differentialAt_map (ℓ : F →+* L) (y : Fin n → F) + (f : MvPolynomial (Fin n) F) (i : Fin n) : + ℓ (differentialAt y f i) = + differentialAt (ℓ ∘ y) (MvPolynomial.map ℓ f) i := by + unfold differentialAt + rw [MvPolynomial.pderiv_map, MvPolynomial.eval_map, MvPolynomial.eval, + MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_comp_left] + rfl + +/-- A coordinate covector given by a finite gradient identity lies in the +equation-defined conormal space. -/ +theorem coordinateCovector_mem_of_gradient_identity + (I : Ideal (MvPolynomial (Fin n) F)) (y xi : Fin n → F) + {r : ℕ} (equations : Fin r → MvPolynomial (Fin n) F) + (hmem : ∀ j, equations j ∈ I) (coefficients : Fin r → F) + (hxi : ∀ i, xi i = ∑ j, coefficients j * differentialAt y (equations j) i) : + coordinateCovector xi ∈ affineConormalSpace y I := by + rw [affineConormalSpace_eq_equationCovectorSpan] + have hcov : coordinateCovector xi = + ∑ j, coefficients j • differentialCovector y (equations j) := by + apply LinearMap.ext + intro v + simp only [coordinateCovector_apply, LinearMap.sum_apply, LinearMap.smul_apply, + differentialCovector_apply, smul_eq_mul, Finset.mul_sum, hxi, Finset.sum_mul] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun i _ ↦ Finset.sum_congr rfl fun j _ ↦ ?_ + ring + rw [hcov] + refine Submodule.sum_mem _ fun j _ ↦ Submodule.smul_mem _ _ ?_ + exact Submodule.subset_span ⟨⟨equations j, hmem j⟩, rfl⟩ + +/-- Equation-defined conormal membership transports along a ring +homomorphism of fields, with the ideal mapped along the same homomorphism. -/ +theorem coordinateCovector_map_mem_affineConormalSpace + (ℓ : F →+* L) (I : Ideal (MvPolynomial (Fin n) F)) (y xi : Fin n → F) + (hxi : coordinateCovector xi ∈ affineConormalSpace y I) : + coordinateCovector (ℓ ∘ xi) ∈ + affineConormalSpace (ℓ ∘ y) (I.map (MvPolynomial.map ℓ)) := by + obtain ⟨r, equations, coefficients, hgradient⟩ := + exists_fin_gradient_identity_of_mem_affineConormalSpace I y xi hxi + refine coordinateCovector_mem_of_gradient_identity _ (ℓ ∘ y) (ℓ ∘ xi) + (fun j ↦ MvPolynomial.map ℓ (equations j).1) + (fun j ↦ Ideal.mem_map_of_mem _ (equations j).2) + (fun j ↦ ℓ (coefficients j)) fun i ↦ ?_ + simp only [Function.comp_apply, hgradient i, map_sum, map_mul, differentialAt_map] + +end CovectorTransport + +/-! ## Generic algebra: the Kähler relation from the lattice lemma -/ + +section KaehlerRelation + +variable {k V F Ω : Type*} +variable [CommRing k] [CommRing V] [IsLocalRing V] [Field F] +variable [Algebra k F] [Algebra V F] +variable [AddCommGroup Ω] [Module k Ω] [Module F Ω] [Module V Ω] +variable [IsScalarTower V F Ω] +variable {d : Derivation k F Ω} {ι : Type*} [Fintype ι] [DecidableEq ι] + +/-- The lattice lemma, rewritten as a single vanishing relation for the +covector `e_{j₀'} - ∑ c_j e_j` where `c_j = t^(a+e-1) b_j ∈ V`. -/ +theorem divisorFrame_kaehler_relation + (D : VisibleDivisorFrame (V := V) d ι) + (hinj : Function.Injective (algebraMap V F)) + (y : ι → F) (i₀ : ι) + (hy : ∀ j, algebraMap V F (D.Q j) / algebraMap V F D.Q₀ = y j) + (hy₁ : algebraMap V F D.Q₁ / algebraMap V F D.Q₀ = y i₀) : + ∃ b : ι → V, + ∑ j, ((if j = i₀ then 1 else 0) - + algebraMap V F (D.t ^ (D.a + D.e - 1) * b j)) • d (y j) = 0 := by + obtain ⟨b, hb⟩ := D.exists_coefficients hinj + refine ⟨b, ?_⟩ + simp only [hy, hy₁] at hb + simp only [sub_smul, Finset.sum_sub_distrib, ite_smul, one_smul, zero_smul, + Finset.sum_ite_eq', Finset.mem_univ, if_true, algebraMap_smul] + rw [← hb, sub_self] + +end KaehlerRelation + +/-! ## Generic algebra: the annihilation identity in the valuation ring -/ + +section Annihilation + +variable {V : Type*} [CommRing V] {ι : Type*} [Fintype ι] [DecidableEq ι] + +/-- The row `(ell₀, xi_j)` annihilates the projective column `(q₀, q_j)`. +Here `q₀ = t^a u`, `q_{i₀} = q₀ p`, `u uinv = 1`, `c_j = t^(a+e-1) b_j`, +`xi_j = δ_{j i₀} - c_j`, and `ell₀ = ∑ t^(e-1) b_j q_j uinv - p`. -/ +theorem annihilation_identity + (t u uinv p : V) (a e : ℕ) (he : 1 ≤ e) (hu : u * uinv = 1) + (q₀ : V) (qs : ι → V) (i₀ : ι) (b : ι → V) + (hq₀ : q₀ = t ^ a * u) (hq₁ : qs i₀ = q₀ * p) : + ((∑ j, t ^ (e - 1) * b j * qs j * uinv) - p) * q₀ + + ∑ j, ((if j = i₀ then 1 else 0) - t ^ (a + e - 1) * b j) * qs j = 0 := by + obtain ⟨e', rfl⟩ := Nat.exists_eq_add_of_le' he + simp only [Nat.add_sub_cancel, sub_mul, Finset.sum_sub_distrib, ite_mul, one_mul, + zero_mul, Finset.sum_ite_eq', Finset.mem_univ, if_true, hq₁, Finset.sum_mul] + have hpow : ∀ j, t ^ (a + (e' + 1) - 1) * b j * qs j = + t ^ e' * b j * qs j * uinv * q₀ := by + intro j + rw [show a + (e' + 1) - 1 = e' + a by omega, pow_add, hq₀] + linear_combination (-(t ^ e' * b j * qs j * t ^ a)) * hu + simp only [hpow] + ring + +end Annihilation + + +/-! ## The generic point as a ratio of normalized projective coordinates -/ + +section GenericPoint + +variable {k : Type u} [Field k] {m : ℕ} + +/-- A common-scale lift of the projective generic point dehomogenizes to the +component coordinates. -/ +theorem componentCoordinate_eq_div + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + (qF : Fin (m + 1) → ComponentFractionField P) + (scale : ComponentFractionField P) + (hq : ∀ a, qF a = scale * componentProjectivePoint P a) + (hq0 : qF 0 ≠ 0) (j : Fin m) : + qF j.succ / qF 0 = componentCoordinate P j := by + have hscale : scale ≠ 0 := by + intro h + apply hq0 + rw [hq 0, h, zero_mul] + rw [hq, hq] + simp only [componentProjectivePoint, Fin.cases_zero, Fin.cases_succ, mul_one] + field_simp + +/-- Every equation of the affine component vanishes at the transported +generic point, for any ring homomorphism out of the function field. -/ +theorem eval_map_componentCoordinate_eq_zero + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) + {L : Type*} [Field L] (ℓ : ComponentFractionField P →+* L) + {g : MvPolynomial (Fin m) k} (hg : g ∈ P.asIdeal) : + MvPolynomial.eval (ℓ ∘ componentCoordinate P) + (MvPolynomial.map (ℓ.comp (algebraMap k (ComponentFractionField P))) g) = 0 := by + rw [MvPolynomial.eval_map, ← MvPolynomial.eval₂_comp_left, + ← componentAffineGenericPointMap_eq_eval₂, + componentAffineGenericPointMap_eq_zero_of_mem P hg, map_zero] + +end GenericPoint + +/-! ## The Laurent lift of the retained completion -/ + +section RetainedLift + +variable {k : Type u} [Field k] [CharZero k] {m : ℕ} + +/-- The retained completion followed by the Laurent embedding. -/ +def retainedLaurentBase + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + V →+* LaurentSeries (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact (algebraMap (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V))).comp (retainedToCompletedPowerSeries W) + +theorem retainedLaurentBase_injective + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + Function.Injective (retainedLaurentBase P i W) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact (IsFractionRing.injective (PowerSeries (ResidueField V)) + (LaurentSeries (ResidueField V))).comp + (retainedToCompletedPowerSeries_injective W) + +/-- The retained completion `V →+* PowerSeries Kres`, followed by the Laurent +embedding, extends uniquely to the component function field. -/ +def retainedLaurentLift + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ComponentFractionField P →+* LaurentSeries (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : IsFractionRing V (ComponentFractionField P) := + (inferInstance : IsFractionRing (↥W.place.valuation) (ComponentFractionField P)) + exact IsFractionRing.lift (A := V) (K := ComponentFractionField P) + (retainedLaurentBase_injective P i W) + +/-- The Laurent lift restricts to the retained completion on `V`. -/ +theorem retainedLaurentLift_algebraMap + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ v : ↥V, retainedLaurentLift P i W (algebraMap V (ComponentFractionField P) v) = + algebraMap (PowerSeries (ResidueField V)) (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W v) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : IsFractionRing V (ComponentFractionField P) := + (inferInstance : IsFractionRing (↥W.place.valuation) (ComponentFractionField P)) + dsimp only + intro v + exact IsFractionRing.lift_algebraMap (A := V) (K := ComponentFractionField P) + (retainedLaurentBase_injective P i W) v + +/-- With the residue-induced ground structure, the Laurent lift restricts to +the terminal consumer's ground map on `k`. -/ +theorem retainedLaurentLift_comp_algebraMap + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + (retainedLaurentLift P i W).comp (algebraMap k (ComponentFractionField P)) = + groundLaurentMap (k := k) (K := ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P i W + letI : IsScalarTower W.coefficientField + (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.coefficientTower + have hcoeff : ∀ c : k, algebraMap k (ComponentFractionField P) c = + algebraMap V (ComponentFractionField P) + (retainedComponentCoefficientMap P i W c) := by + intro c + change algebraMap k (ComponentFractionField P) c = + ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : ComponentFractionField P) + calc + algebraMap k (ComponentFractionField P) c = + algebraMap W.coefficientField (ComponentFractionField P) + (algebraMap k W.coefficientField c) := + IsScalarTower.algebraMap_apply k W.coefficientField + (ComponentFractionField P) c + _ = ((relativeCoefficientMap W.coefficientField W.place + (algebraMap k W.coefficientField c) : V) : + ComponentFractionField P) := + (DFunLike.congr_fun + (relativeCoefficientMap_commutes W.coefficientField W.place) + (algebraMap k W.coefficientField c)).symm + have hlift : (retainedLaurentLift P i W).comp + (algebraMap k (ComponentFractionField P)) = + retainedLaurentCoefficientMap P i W := by + refine RingHom.ext fun c ↦ ?_ + change retainedLaurentLift P i W (algebraMap k (ComponentFractionField P) c) = _ + rw [hcoeff, retainedLaurentLift_algebraMap] + rfl + exact hlift.trans (retainedLaurentCoefficientMap_eq_groundLaurentMap P i W) + +/-- The transported generic point is the dehomogenized completed projective +column. -/ +theorem retainedLaurentLift_componentCoordinate + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (i : Fin m) + (W : Data k (ComponentFractionField P) (componentCoordinate P i)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + q 0 ≠ 0 → + retainedLaurentLift P i W ∘ componentCoordinate P = + dehomogenizedPoint + (laurentColumn fun a ↦ retainedToCompletedPowerSeries W (q a)) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro q scale hq hq0 + have hq0F : (q 0 : ComponentFractionField P) ≠ 0 := fun h ↦ hq0 (Subtype.ext h) + have hlift : ∀ v : V, retainedLaurentLift P i W (algebraMap V (ComponentFractionField P) v) = + algebraMap (PowerSeries (ResidueField V)) (LaurentSeries (ResidueField V)) + (retainedToCompletedPowerSeries W v) := retainedLaurentLift_algebraMap P i W + have hdiv : ∀ j : Fin m, componentCoordinate P j = + algebraMap V (ComponentFractionField P) (q j.succ) / + algebraMap V (ComponentFractionField P) (q 0) := fun j ↦ + (componentCoordinate_eq_div P (fun a ↦ (q a : ComponentFractionField P)) + scale hq hq0F j).symm + funext j + simp only [Function.comp_apply, dehomogenizedPoint, laurentColumn, hdiv, map_div₀, hlift] + rfl + +end RetainedLift +/-! ## Abstract assembly -/ + +section AbstractAssembly + +variable {k F Kres V : Type u} [Field k] [Field F] [Algebra k F] [Field Kres] [Algebra k Kres] +variable [CommRing V] [IsLocalRing V] [Algebra V F] +variable [SMulCommClass k V F] +variable {m : ℕ} + +/-- Abstract assembly of the one-row datum. `φ` is the completion of `V` +(injective, killing the residue of nonunits), `ℓ` the compatible extension +to `F` with the ground identification, `q` the normalized projective +coordinates of the generic point `y`, `D` the divisor frame on `q`, and +`hbridge` the generic-point Kähler bridge. -/ +theorem regularizedOneRowConormalData_of_transport + (hm : 0 < m) (I : Ideal (MvPolynomial (Fin m) k)) (y : Fin m → F) + (hIy : ∀ g ∈ I, MvPolynomial.eval₂ (algebraMap k F) y g = 0) + (hinj : Function.Injective (algebraMap V F)) + (φ : V →+* PowerSeries Kres) (hφinj : Function.Injective φ) + (hφconst : ∀ v : V, ¬IsUnit v → PowerSeries.constantCoeff (R := Kres) (φ v) = 0) + (ℓ : F →+* LaurentSeries Kres) + (hℓ : ∀ v : V, ℓ (algebraMap V F v) = + algebraMap (PowerSeries Kres) (LaurentSeries Kres) (φ v)) + (hground : ℓ.comp (algebraMap k F) = groundLaurentMap (k := k) (K := Kres)) + (q : Fin (m + 1) → V) (hq0 : q 0 ≠ 0) + (hdiv : ∀ j, algebraMap V F (q j.succ) / algebraMap V F (q 0) = y j) + (p : V) (hratio : q (Fin.succ ⟨0, hm⟩) = q 0 * p) + (D : VisibleDivisorFrame (V := V) (KaehlerDifferential.D k F) (Fin m)) + (hQ₀ : D.Q₀ = q 0) (hQ₁ : D.Q₁ = q (Fin.succ ⟨0, hm⟩)) + (hQ : ∀ j, D.Q j = q (Fin.succ j)) + (hbridge : ∀ xi : Fin m → F, + ∑ j, xi j • KaehlerDifferential.D k F (y j) = 0 → + coordinateCovector xi ∈ affineConormalSpace y + (I.map (MvPolynomial.map (algebraMap k F)))) : + Nonempty (RegularizedOneRowConormalData (k := k) (K := Kres) hm I + (fun a ↦ φ (q a))) := by + let i₀ : Fin m := ⟨0, hm⟩ + let ψ : PowerSeries Kres →+* LaurentSeries Kres := + algebraMap (PowerSeries Kres) (LaurentSeries Kres) + have hpoint : ℓ ∘ y = dehomogenizedPoint (laurentColumn fun a ↦ φ (q a)) := by + funext j + simp only [Function.comp_apply, dehomogenizedPoint, laurentColumn, ← hdiv, map_div₀, hℓ] + obtain ⟨b, hb⟩ := divisorFrame_kaehler_relation D hinj y i₀ + (fun j ↦ by rw [hQ j, hQ₀]; exact hdiv j) (by rw [hQ₁, hQ₀]; exact hdiv i₀) + let c : Fin m → V := fun j ↦ D.t ^ (D.a + D.e - 1) * b j + let xiV : Fin m → V := fun j ↦ (if j = i₀ then 1 else 0) - c j + let xi : Fin m → F := fun j ↦ (if j = i₀ then 1 else 0) - algebraMap V F (c j) + have hxi : ∀ j, algebraMap V F (xiV j) = xi j := by + intro j + simp only [xiV, xi, map_sub] + split_ifs <;> simp + have hconormalF : coordinateCovector xi ∈ affineConormalSpace y + (I.map (MvPolynomial.map (algebraMap k F))) := hbridge xi hb + have hcnonunit : ∀ j, ¬IsUnit (c j) := by + intro j + have hpos : 0 < D.a + D.e - 1 := by + have := D.one_le_a; have := D.one_le_e; omega + have hmem : c j ∈ maximalIdeal V := + Ideal.mul_mem_right _ _ (Ideal.pow_mem_of_mem _ D.t_mem _ hpos) + exact mem_nonunits_iff.1 ((mem_maximalIdeal _).1 hmem) + let uinv : V := ↑D.u_unit.unit⁻¹ + have hu : D.u * uinv = 1 := D.u_unit.mul_val_inv + let ell₀ : V := (∑ j, D.t ^ (D.e - 1) * b j * q j.succ * uinv) - p + have hann : ell₀ * q 0 + ∑ j, xiV j * q j.succ = 0 := + annihilation_identity D.t D.u uinv p D.a D.e D.one_le_e hu + (q 0) (fun j ↦ q j.succ) i₀ b (hQ₀.symm.trans D.Q₀_eq) hratio + let ell : Fin (m + 1) → PowerSeries Kres := + Fin.cases (φ ell₀) (fun j ↦ φ (xiV j)) + have hcol : (fun i ↦ laurentColumn ell i.succ) = ℓ ∘ xi := by + funext i + simp only [laurentColumn, ell, Fin.cases_succ, Function.comp_apply, ← hxi, hℓ] + have hideal : (I.map (MvPolynomial.map (algebraMap k F))).map (MvPolynomial.map ℓ) = + I.map (groundPolynomialMap (k := k) (K := Kres) (Fin m)) := by + rw [Ideal.map_map] + congr 1 + refine RingHom.ext fun f ↦ ?_ + simp only [RingHom.comp_apply, MvPolynomial.map_map, groundPolynomialMap, hground] + refine ⟨{ + ell := ell + q_origin_ne := ?_ + projective_annihilation := ?_ + base_vanish := ?_ + conormal := ?_ + residue_axis := ?_ }⟩ + · intro h + exact hq0 (hφinj (h.trans (map_zero _).symm)) + · have h := congrArg (ψ.comp φ) hann + simp only [RingHom.comp_apply, map_add, map_mul, map_sum, map_zero] at h + simpa only [laurentColumn, Fin.sum_univ_succ, ell, Fin.cases_zero, Fin.cases_succ] + using h + · intro f hf + rw [← hpoint] + have hle : I.map (groundPolynomialMap (k := k) (K := Kres) (Fin m)) ≤ + RingHom.ker (MvPolynomial.eval (ℓ ∘ y)) := by + refine Ideal.map_le_iff_le_comap.mpr fun g hg ↦ ?_ + rw [Ideal.mem_comap, RingHom.mem_ker, groundPolynomialMap, ← hground, + MvPolynomial.eval_map, ← MvPolynomial.eval₂_comp_left, hIy g hg, map_zero] + exact hle hf + · rw [hcol, ← hpoint, ← hideal] + exact coordinateCovector_map_mem_affineConormalSpace ℓ _ _ xi hconormalF + · funext j + simp only [residueColumn, ell, Fin.cases_succ, xiV, map_sub, hφconst (c j) (hcnonunit j), + sub_zero] + split_ifs <;> simp + +end AbstractAssembly + + +/-! ## The concrete transport theorem -/ + +section Assembly + +variable {k : Type u} [Field k] [CharZero k] {m : ℕ} + +/-- The transport theorem at a retained boundary place. Explicit inputs: +normalized projective coordinates `q` of the generic point in the retained +valuation ring (as produced by +`exists_normalizedProjectivePoint_relativeRetainedBoundaryPlace`), a visible +divisor frame `D` on them, and the generic-point Kähler bridge `hbridge`. -/ +theorem exists_regularizedOneRowConormalData + (P : PrimeSpectrum (MvPolynomial (Fin m) k)) (hm : 0 < m) + (W : Data k (ComponentFractionField P) (componentCoordinate P ⟨0, hm⟩)) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P ⟨0, hm⟩ W + ∀ (q : Fin (m + 1) → V) (scale : ComponentFractionField P), + q 0 ≠ 0 → + (∀ a, (q a : ComponentFractionField P) = + scale * componentProjectivePoint P a) → + q (Fin.succ ⟨0, hm⟩) = q 0 * W.place.parameter → + ∀ D : VisibleDivisorFrame (V := V) + (KaehlerDifferential.D k (ComponentFractionField P)) (Fin m), + D.Q₀ = q 0 → D.Q₁ = q (Fin.succ ⟨0, hm⟩) → (∀ j, D.Q j = q (Fin.succ j)) → + (∀ xi : Fin m → ComponentFractionField P, + ∑ j, xi j • KaehlerDifferential.D k (ComponentFractionField P) + (componentCoordinate P j) = 0 → + coordinateCovector xi ∈ affineConormalSpace (componentCoordinate P) + (P.asIdeal.map (MvPolynomial.map + (algebraMap k (ComponentFractionField P))))) → + Nonempty (RegularizedOneRowConormalData (k := k) (K := ResidueField V) + hm P.asIdeal (fun a ↦ retainedToCompletedPowerSeries W (q a))) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) + (ComponentFractionField P) := W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + letI : Algebra k (ResidueField V) := + retainedResidueGroundAlgebra P ⟨0, hm⟩ W + dsimp only + intro q scale hq0 hq hratio D hQ₀ hQ₁ hQ hbridge + have hq0F : (q 0 : ComponentFractionField P) ≠ 0 := fun h ↦ hq0 (Subtype.ext h) + have hIy : ∀ g ∈ P.asIdeal, + MvPolynomial.eval₂ (algebraMap k (ComponentFractionField P)) + (componentCoordinate P) g = 0 := by + intro g hg + rw [← componentAffineGenericPointMap_eq_eval₂] + exact componentAffineGenericPointMap_eq_zero_of_mem P hg + exact regularizedOneRowConormalData_of_transport hm P.asIdeal (componentCoordinate P) + hIy Subtype.val_injective (retainedToCompletedPowerSeries W) + (retainedToCompletedPowerSeries_injective W) + (retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit W) + (retainedLaurentLift P ⟨0, hm⟩ W) + (retainedLaurentLift_algebraMap P ⟨0, hm⟩ W) + (retainedLaurentLift_comp_algebraMap P ⟨0, hm⟩ W) + q hq0 (componentCoordinate_eq_div P (fun a ↦ (q a : ComponentFractionField P)) + scale hq hq0F) + W.place.parameter hratio D hQ₀ hQ₁ hQ hbridge + +end Assembly + + +end + +end Stafford38.Geometry.RetainedPlaceConormalTransport diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetainedProjectiveCompletion.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetainedProjectiveCompletion.lean new file mode 100644 index 0000000000..c57b19cdbd --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetainedProjectiveCompletion.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveValuationNormalization +import LeanPool.Stafford38.Stafford38.Geometry.RelativeRetainedBoundaryPlace +import Mathlib.RingTheory.PowerSeries.Inverse + +/-! +# Transport from a retained valuation ring to its power-series completion + +The completed-DVR equivalence turns every valuation-ring coordinate into a +power series over the actual residue field. Krull intersection makes this +coordinate map injective, so projective nonvanishing is preserved. +-/ + +namespace Stafford38.Geometry.RetainedProjectiveCompletion + +open IsLocalRing +open Stafford38.Geometry.AsymptoticDivisorExistence +open Stafford38.Geometry.ProjectiveValuationNormalization +open Stafford38.Geometry.RelativeCoefficientDVR +open Stafford38.Geometry.RelativeRetainedBoundaryPlace + +noncomputable section + + +universe u v + +/-- Map retained valuation-ring coordinates into the corresponding +power-series ring via the actual adic completion. -/ +def retainedToCompletedPowerSeries + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] {x : K} (W : Data k K x) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + V →+* PowerSeries (ResidueField V) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact W.completedPowerSeriesEquiv.symm.toRingHom.comp + (algebraMap V (AdicCompletion (maximalIdeal V) V)) + +/-- Completion transport does not collapse a retained coordinate. -/ +theorem retainedToCompletedPowerSeries_injective + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] {x : K} (W : Data k K x) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + Function.Injective (retainedToCompletedPowerSeries W) := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + exact W.completedPowerSeriesEquiv.symm.injective.comp + (adicCompletion_algebraMap_injective (maximalIdeal V) + (maximalIdeal.isMaximal V).ne_top) + +/-- A retained nonunit has zero constant coefficient in the completed +power-series chart. -/ +theorem retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] {x : K} (W : Data k K x) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ v : ↥V, ¬IsUnit v → + PowerSeries.constantCoeff (R := ResidueField V) + (retainedToCompletedPowerSeries W v) = 0 := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro v hv + by_contra hconstant + have hseries : IsUnit (retainedToCompletedPowerSeries W v) := + PowerSeries.isUnit_iff_constantCoeff.mpr + (isUnit_iff_ne_zero.mpr hconstant) + have hcompletion : IsUnit + (algebraMap V (AdicCompletion (maximalIdeal V) V) v) := by + have hmap := hseries.map W.completedPowerSeriesEquiv.toMonoidHom + simpa [retainedToCompletedPowerSeries] using hmap + have hlevel := hcompletion.map + (AdicCompletion.evalₐ (maximalIdeal V) 1).toRingHom.toMonoidHom + have heval : AdicCompletion.evalₐ (maximalIdeal V) 1 + (algebraMap V (AdicCompletion (maximalIdeal V) V) v) = + Ideal.Quotient.mk ((maximalIdeal V) ^ 1) v := by + exact (AdicCompletion.evalₐ (maximalIdeal V) 1).commutes v + change IsUnit (AdicCompletion.evalₐ (maximalIdeal V) 1 + (algebraMap V (AdicCompletion (maximalIdeal V) V) v)) at hlevel + rw [heval] at hlevel + have hvmax : v ∈ maximalIdeal V := by + rw [mem_maximalIdeal, mem_nonunits_iff] + exact hv + have hvpow : v ∈ (maximalIdeal V) ^ 1 := by simpa only [pow_one] using hvmax + have hzero : Ideal.Quotient.mk ((maximalIdeal V) ^ 1) v = 0 := + Ideal.Quotient.eq_zero_iff_mem.mpr hvpow + rw [hzero] at hlevel + letI : Nontrivial (V ⧸ (maximalIdeal V) ^ 1) := + Ideal.Quotient.nontrivial_iff.mpr (by + simpa only [pow_one] using (maximalIdeal.isMaximal V).ne_top) + exact not_isUnit_zero hlevel + +/-- A normalized valuation-ring projective family remains normalized and +nonzero after transport to the power-series completion. -/ +theorem retainedCompleted_family_properties + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] {x : K} (W : Data k K x) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ {ι : Type v} [Fintype ι] + (q : ι → V) (chart zero axis : ι), + q chart = 1 → q zero ≠ 0 → + q axis = q zero * W.place.parameter → + let qhat := fun i ↦ retainedToCompletedPowerSeries W (q i) + qhat chart = 1 ∧ qhat zero ≠ 0 ∧ + qhat axis = qhat zero * + retainedToCompletedPowerSeries W W.place.parameter := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro ι _ q chart zero axis hchart hzero haxis + dsimp + refine ⟨by rw [hchart, map_one], ?_, ?_⟩ + · simpa using (retainedToCompletedPowerSeries_injective W).ne hzero + · rw [haxis, map_mul] + +/-- The retained parameter and a nonunit projective denominator supply all +nonvanishing and residue-vanishing fields needed by the projective order-gap +consumer after completion. -/ +theorem retainedCompleted_projective_order_properties + {k K : Type u} [Field k] [CharZero k] + [Field K] [Algebra k K] {x : K} (W : Data k K x) : + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + ∀ {ι : Type v} [Fintype ι] + (q : ι → V) (chart zero axis : ι), + q chart = 1 → q zero ≠ 0 → ¬IsUnit (q zero) → + q axis = q zero * W.place.parameter → + let qhat := fun i ↦ retainedToCompletedPowerSeries W (q i) + let ratio := retainedToCompletedPowerSeries W W.place.parameter + qhat chart = 1 ∧ qhat zero ≠ 0 ∧ ratio ≠ 0 ∧ + PowerSeries.constantCoeff (R := ResidueField V) (qhat zero) = 0 ∧ + PowerSeries.constantCoeff (R := ResidueField V) ratio = 0 ∧ + qhat axis = qhat zero * ratio := by + letI : Algebra (CoordinateZeroLocalRing W.coefficientField) K := + W.ambientAlgebra + let V := W.place.valuation.toSubring + letI : IsDiscreteValuationRing V := W.place.isDiscrete + letI : Algebra W.coefficientField V := + (relativeCoefficientMap W.coefficientField W.place).toAlgebra + dsimp only + intro ι _ q chart zero axis hchart hzero hzero_nonunit haxis + obtain ⟨hqchart, hqzero, hqaxis⟩ := + retainedCompleted_family_properties W q chart zero axis + hchart hzero haxis + refine ⟨hqchart, hqzero, + (by simpa using + (retainedToCompletedPowerSeries_injective W).ne W.place.parameter_ne), + retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit W + (q zero) hzero_nonunit, + retainedToCompletedPowerSeries_constantCoeff_eq_zero_of_nonunit W + W.place.parameter W.place.parameter_nonunit, + hqaxis⟩ + + +end + +end Stafford38.Geometry.RetainedProjectiveCompletion diff --git a/LeanPool/Stafford38/Stafford38/Geometry/RetractionSpecialization.lean b/LeanPool/Stafford38/Stafford38/Geometry/RetractionSpecialization.lean new file mode 100644 index 0000000000..e6779f6ceb --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/RetractionSpecialization.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Retraction correction and power-series specialization + +This file contains only elementary algebra intended for use in a future +formalization of the asymptotic-conormal argument. In particular, it does not formalize a DVR, +normalization, a Grassmannian limit, or coisotropy. The useful point is that +the two algebraic operations needed by that argument are explicit: + +* a left inverse for a column matrix gives an annihilator by a retraction; +* taking the residue of a power series commutes with polynomial evaluation. + +The last theorem records the resulting polynomial-specialization +contradiction for an arbitrary variable type and arbitrary specialization +vector. +-/ + +namespace Stafford38.GeometryRetractionSpecialization + +noncomputable section + +universe u v w + +/-! ## Rows, columns, and the explicit retraction correction -/ + +variable {R : Type u} [CommRing R] + +/-- A row vector multiplied by a matrix on the right. -/ +def rowMul {ι κ : Type*} [Fintype ι] (a : ι → R) (B : Matrix ι κ R) : κ → R := + fun j => ∑ i, a i * B i j + +theorem rowMul_mul {ι κ μ : Type*} [Fintype ι] [Fintype κ] + (a : ι → R) (B : Matrix ι κ R) (C : Matrix κ μ R) : + rowMul (rowMul a B) C = rowMul a (B * C) := by + funext j + simp only [rowMul, Matrix.mul_apply] + calc + (∑ x, (∑ i, a i * B i x) * C x j) = + ∑ x, ∑ i, (a i * B i x) * C x j := by + apply Finset.sum_congr rfl + intro x hx + rw [Finset.sum_mul] + _ = ∑ i, ∑ x, (a i * B i x) * C x j := Finset.sum_comm + _ = ∑ i, a i * (∑ x, B i x * C x j) := by + apply Finset.sum_congr rfl + intro i hi + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro x hx + ring + +theorem map_rowMul {S : Type v} [CommRing S] + {ι κ : Type*} [Fintype ι] (f : R →+* S) + (a : ι → R) (B : Matrix ι κ R) (j : κ) : + f (rowMul a B j) = + rowMul (fun i => f (a i)) (fun i l => f (B i l)) j := by + simp [rowMul] + +theorem rowMul_sub {ι κ : Type*} [Fintype ι] + (a b : ι → R) (B : Matrix ι κ R) : + rowMul (fun i => a i - b i) B = + fun j => rowMul a B j - rowMul b B j := by + funext j + simp [rowMul, Finset.sum_sub_distrib, sub_mul] + +theorem rowMul_zero {ι κ : Type*} [Fintype ι] + (B : Matrix ι κ R) : rowMul (fun _ => (0 : R)) B = 0 := by + funext j + simp [rowMul] + +/-- +The retraction correction for a row `a` and a column matrix `B`. + +If `C * B = 1`, then `C` is a coordinate retraction on the columns of `B`. +The displayed subtraction is the usual projection onto the annihilator of +those columns. +-/ +def annihilatorLift {ι κ : Type*} [Fintype ι] [Fintype κ] + (a : ι → R) (B : Matrix ι κ R) (C : Matrix κ ι R) : ι → R := + fun i => a i - rowMul (rowMul a B) C i + +theorem annihilatorLift_rowMul_eq_zero {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq κ] + (a : ι → R) (B : Matrix ι κ R) (C : Matrix κ ι R) + (hCB : C * B = 1) : + rowMul (annihilatorLift a B C) B = 0 := by + change rowMul (fun i => a i - rowMul (rowMul a B) C i) B = 0 + rw [rowMul_sub] + rw [rowMul_mul, rowMul_mul] + rw [hCB, Matrix.mul_one] + exact funext (fun j => sub_self (rowMul a B j)) + +theorem map_annihilatorLift {S : Type v} [CommRing S] + {ι κ : Type*} [Fintype ι] [Fintype κ] + (f : R →+* S) (a : ι → R) (B : Matrix ι κ R) (C : Matrix κ ι R) (i : ι) : + f (annihilatorLift a B C i) = + annihilatorLift (fun j => f (a j)) + (fun j l => f (B j l)) (fun l j => f (C l j)) i := by + simp only [annihilatorLift, map_sub] + rw [map_rowMul f (rowMul a B) C i] + have hinner : + rowMul (fun j => f (rowMul a B j)) (fun l j => f (C l j)) i = + rowMul (rowMul (fun j => f (a j)) (fun j l => f (B j l))) + (fun l j => f (C l j)) i := by + apply congrArg (fun z => rowMul z (fun l j => f (C l j)) i) + funext j + exact map_rowMul f a B j + exact congrArg (fun z => f (a i) - z) hinner + +/-- +Explicit residue-preserving annihilator lift. + +The input row is any coefficientwise lift of the residue row. The correction +preserves that residue whenever the residue row annihilates the reduced +columns. Exact annihilation is supplied separately by +`annihilatorLift_rowMul_eq_zero` under the hypothesis `C * B = 1`. +-/ +theorem residue_annihilatorLift_eq + {S : Type v} [CommRing S] + {ι κ : Type*} [Fintype ι] [Fintype κ] + (f : R →+* S) (a : ι → R) (a₀ : ι → S) + (B : Matrix ι κ R) (C : Matrix κ ι R) + (ha : ∀ i, f (a i) = a₀ i) + (h₀ : rowMul a₀ (fun i j => f (B i j)) = 0) : + ∀ i, f (annihilatorLift a B C i) = a₀ i := by + intro i + rw [map_annihilatorLift] + simp only [annihilatorLift, ha] + rw [h₀] + simp [rowMul] + +/-! ## Power-series columns and residue -/ + +/-- A column with entries in a one-variable formal power-series ring. -/ +abbrev PowerSeriesColumn (k : Type*) (ι : Type*) := ι → PowerSeries k + +def residueColumn {k : Type*} [CommRing k] {ι : Type*} + (a : PowerSeriesColumn k ι) : ι → k := + fun i => PowerSeries.constantCoeff (a i) + +def constantColumn {k : Type*} [CommRing k] {ι : Type*} + (a : ι → k) : PowerSeriesColumn k ι := + fun i => PowerSeries.C (a i) + +@[simp] theorem residueColumn_constantColumn {k : Type*} [CommRing k] {ι : Type*} + (a : ι → k) : residueColumn (constantColumn a) = a := by + funext i + simp [residueColumn, constantColumn] + +theorem powerSeries_annihilatorLift_rowMul_eq_zero + {k : Type*} [CommRing k] {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq κ] + (a : PowerSeriesColumn k ι) (B : Matrix ι κ (PowerSeries k)) + (C : Matrix κ ι (PowerSeries k)) (hCB : C * B = 1) : + rowMul (annihilatorLift a B C) B = 0 := + annihilatorLift_rowMul_eq_zero a B C hCB + +theorem residue_powerSeries_annihilatorLift_eq + {k : Type*} [CommRing k] {ι κ : Type*} [Fintype ι] [Fintype κ] + (a : PowerSeriesColumn k ι) (a₀ : ι → k) + (B : Matrix ι κ (PowerSeries k)) (C : Matrix κ ι (PowerSeries k)) + (ha : residueColumn a = a₀) + (h₀ : rowMul a₀ (fun i j => PowerSeries.constantCoeff (B i j)) = 0) : + ∀ i, residueColumn (annihilatorLift a B C) i = a₀ i := by + apply residue_annihilatorLift_eq PowerSeries.constantCoeff a a₀ B C + · intro i + simpa [residueColumn] using congrFun ha i + · simpa [residueColumn] using h₀ + +/-- A split column matrix admits a corrected row which both annihilates the +matrix and retains the prescribed residue. -/ +theorem powerSeries_annihilatorLift_spec + {k : Type*} [CommRing k] {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq κ] + (a : PowerSeriesColumn k ι) (a₀ : ι → k) + (B : Matrix ι κ (PowerSeries k)) (C : Matrix κ ι (PowerSeries k)) + (hCB : C * B = 1) (ha : residueColumn a = a₀) + (h₀ : rowMul a₀ (fun i j => PowerSeries.constantCoeff (B i j)) = 0) : + rowMul (annihilatorLift a B C) B = 0 ∧ + residueColumn (annihilatorLift a B C) = a₀ := by + refine ⟨powerSeries_annihilatorLift_rowMul_eq_zero a B C hCB, ?_⟩ + funext i + exact residue_powerSeries_annihilatorLift_eq a a₀ B C ha h₀ i + +/-! ## Residue/evaluation commutation for multivariate polynomials -/ + +theorem residue_eval_map + {k : Type*} [CommRing k] {σ : Type*} + (P : MvPolynomial σ k) (v : σ → PowerSeries k) : + PowerSeries.constantCoeff + (MvPolynomial.eval v (MvPolynomial.map PowerSeries.C P)) = + MvPolynomial.eval (residueColumn v) P := by + rw [MvPolynomial.eval_map] + induction P using MvPolynomial.induction_on with + | C r => simp + | add p q hp hq => simp [hp, hq] + | mul_X p i hp => + simp [hp, residueColumn, mul_comm] + +theorem residue_eval_eq_zero_of_eval_map_eq_zero + {k : Type*} [CommRing k] {σ : Type*} + (P : MvPolynomial σ k) (v : σ → PowerSeries k) + (hv : MvPolynomial.eval v (MvPolynomial.map PowerSeries.C P) = 0) : + MvPolynomial.eval (residueColumn v) P = 0 := by + rw [← residue_eval_map P v, hv] + simp + +/-! ## Polynomial-specialization contradiction -/ + +theorem no_axis_specialization + {k : Type*} [CommRing k] {σ : Type*} + (P : MvPolynomial σ k) (v : σ → PowerSeries k) (axis : σ → k) + (hres : residueColumn v = axis) + (hvanish : MvPolynomial.eval v (MvPolynomial.map PowerSeries.C P) = 0) + (haxis : MvPolynomial.eval axis P ≠ 0) : False := by + apply haxis + rw [← hres] + exact residue_eval_eq_zero_of_eval_map_eq_zero P v hvanish + +/-! ## Small concrete pins used by the focused checker -/ + +example {k : Type*} [CommRing k] {σ : Type*} + (P : MvPolynomial σ k) (v : σ → PowerSeries k) : + PowerSeries.constantCoeff + (MvPolynomial.eval v (MvPolynomial.map PowerSeries.C P)) = + MvPolynomial.eval (residueColumn v) P := + residue_eval_map P v + +example {k : Type*} [CommRing k] {σ : Type*} + (P : MvPolynomial σ k) (v : σ → PowerSeries k) (axis : σ → k) + (hres : residueColumn v = axis) + (hvanish : MvPolynomial.eval v (MvPolynomial.map PowerSeries.C P) = 0) + (haxis : MvPolynomial.eval axis P ≠ 0) : False := + no_axis_specialization P v axis hres hvanish haxis + + +end + +end Stafford38.GeometryRetractionSpecialization diff --git a/LeanPool/Stafford38/Stafford38/Geometry/ScalarExtensionPoints.lean b/LeanPool/Stafford38/Stafford38/Geometry/ScalarExtensionPoints.lean new file mode 100644 index 0000000000..09e8ea9c71 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/ScalarExtensionPoints.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Nullstellensatz +import LeanPool.Stafford38.Stafford38.Geometry.AffineConormalClosure + +/-! +# Scalar extension and geometric points + +This file gives the coefficient-extension bridge for the field-valued affine +geometry used by the characteristic-support and conormal arguments. All +polynomial maps, ideal maps/comaps, and evaluation maps are displayed +explicitly. + +For an ideal `J` over `k`, its geometric reduced extension is defined as the +radical of the extended ideal, not as the extension of `J.radical`. The two +zero loci agree over every extension field. No assertion that radicals, +closures, or ideal contractions commute with base change is made here. +-/ + +namespace Stafford38.Geometry.ScalarExtensionPoints + +open Stafford38.Characteristic +open Stafford38.Characteristic.BaseRelativePoisson +open Stafford38.Characteristic.BaseZeroSection +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicInitialIdealHomogeneous +open Stafford38.Characteristic.ReducedSupportIdeal +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.AffineConormalSpan +open Stafford38.Geometry.CoisotropicTranslation +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration + +noncomputable section + +variable {k K : Type*} [Field k] [Field K] [Algebra k K] +variable {σ : Type*} {n : ℕ} + +/-- Coefficient extension on a multivariable polynomial ring. -/ +def scalarPolynomialMap (σ : Type*) : + MvPolynomial σ k →+* MvPolynomial σ K := + MvPolynomial.map (algebraMap k K) + +/-- Coefficient extension is injective for a field extension. -/ +theorem scalarPolynomialMap_injective (σ : Type*) : + Function.Injective (scalarPolynomialMap (k := k) (K := K) σ) := + MvPolynomial.map_injective (algebraMap k K) + (FaithfulSMul.algebraMap_injective k K) + +/-- Evaluation of a coefficient-extended polynomial at a `K`-point is +exactly `eval₂` with the structure map on coefficients. -/ +theorem eval_scalarPolynomialMap (q : σ → K) (f : MvPolynomial σ k) : + MvPolynomial.eval q (scalarPolynomialMap (k := k) (K := K) σ f) = + MvPolynomial.eval₂ (algebraMap k K) q f := by + exact MvPolynomial.eval_map (algebraMap k K) q f + +/-- Exact point semantics of ideal extension: a `K`-point kills the extended +ideal iff it kills the image of every member of the original ideal. -/ +theorem mem_zeroLocus_map_iff + (J : Ideal (MvPolynomial σ k)) (q : σ → K) : + q ∈ MvPolynomial.zeroLocus K + (J.map (scalarPolynomialMap (k := k) (K := K) σ)) ↔ + ∀ f ∈ J, MvPolynomial.eval₂ (algebraMap k K) q f = 0 := by + constructor + · intro hq f hf + have h := hq + (scalarPolynomialMap (k := k) (K := K) σ f) + (Ideal.mem_map_of_mem + (scalarPolynomialMap (k := k) (K := K) σ) hf) + simpa [eval_scalarPolynomialMap] using h + · intro hq + rw [Ideal.map, MvPolynomial.zeroLocus_span] + rintro _ ⟨f, hf, rfl⟩ + simpa [eval_scalarPolynomialMap] using hq f hf + +/-- Polynomials over `k` vanishing on a set of `K`-points. This is the +contraction of the ordinary `K`-valued vanishing ideal. -/ +def extensionValuedVanishingIdeal (S : Set (σ → K)) : + Ideal (MvPolynomial σ k) := + (MvPolynomial.vanishingIdeal K S).comap + (scalarPolynomialMap (k := k) (K := K) σ) + +theorem mem_extensionValuedVanishingIdeal_iff + (S : Set (σ → K)) (f : MvPolynomial σ k) : + f ∈ extensionValuedVanishingIdeal (k := k) (K := K) S ↔ + ∀ q ∈ S, MvPolynomial.eval₂ (algebraMap k K) q f = 0 := by + simp [extensionValuedVanishingIdeal, eval_scalarPolynomialMap] + +/-- Exact Galois bridge between ideal extension and vanishing on +extension-valued points. -/ +theorem subset_zeroLocus_map_iff_le_extensionValuedVanishingIdeal + (J : Ideal (MvPolynomial σ k)) (S : Set (σ → K)) : + S ⊆ MvPolynomial.zeroLocus K + (J.map (scalarPolynomialMap (k := k) (K := K) σ)) ↔ + J ≤ extensionValuedVanishingIdeal (k := k) (K := K) S := by + constructor + · intro h f hf + rw [mem_extensionValuedVanishingIdeal_iff] + intro q hq + exact (mem_zeroLocus_map_iff J q).mp (h hq) f hf + · intro h q hq + rw [mem_zeroLocus_map_iff] + intro f hf + exact (mem_extensionValuedVanishingIdeal_iff S f).mp (h hf) q hq + +/-- Taking a radical after scalar extension does not change the set of +`K`-valued zeros. This does not identify that radical with the extension of +the ground-field radical. -/ +theorem zeroLocus_radical (L : Ideal (MvPolynomial σ K)) : + MvPolynomial.zeroLocus K L.radical = MvPolynomial.zeroLocus K L := by + apply Set.Subset.antisymm + · exact MvPolynomial.zeroLocus_anti_mono Ideal.le_radical + · intro q hq f hf + exact MvPolynomial.radical_le_vanishingIdeal_zeroLocus L hf q hq + +/-- The reduced geometric extension of an ideal. Reduction is deliberately +performed after coefficient extension. -/ +def geometricRadicalExtension (J : Ideal (MvPolynomial σ k)) : + Ideal (MvPolynomial σ K) := + (J.map (scalarPolynomialMap (k := k) (K := K) σ)).radical + +/-- Exact geometric-point semantics of the reduced extension. -/ +theorem mem_zeroLocus_geometricRadicalExtension_iff + (J : Ideal (MvPolynomial σ k)) (q : σ → K) : + q ∈ MvPolynomial.zeroLocus K + (geometricRadicalExtension (k := k) (K := K) J) ↔ + ∀ f ∈ J, MvPolynomial.eval₂ (algebraMap k K) q f = 0 := by + rw [geometricRadicalExtension, zeroLocus_radical, + mem_zeroLocus_map_iff] + +/-- Coefficient extension commutes with the explicit embedding of base +coordinates into phase space. -/ +theorem scalarPolynomialMap_baseLift (f : MvPolynomial (Fin n) k) : + scalarPolynomialMap (k := k) (K := K) (PhaseVar n) (baseLift f) = + baseLift (scalarPolynomialMap (k := k) (K := K) (Fin n) f) := by + exact MvPolynomial.map_rename (algebraMap k K) Sum.inl f + +/-- The always-valid map/comap comparison for the base-coordinate square. +The orientation is important: extension of the old contraction is contained +in the contraction of the extended ideal. The reverse inclusion would need +the flat Cartesian base-change/intersection theorem for this polynomial +square; no such equality is assumed. -/ +theorem map_baseContraction_le_extendedBaseContraction + (J : Ideal (SymbolRing k n)) : + (J.comap + (baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom).map + (scalarPolynomialMap (k := k) (K := K) (Fin n)) ≤ + (J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n))).comap + (baseLift : MvPolynomial (Fin n) K →ₐ[K] SymbolRing K n).toRingHom := by + rw [Ideal.map_le_iff_le_comap] + intro f hf + change baseLift (scalarPolynomialMap (k := k) (K := K) (Fin n) f) ∈ + J.map (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) + rw [← scalarPolynomialMap_baseLift] + exact Ideal.mem_map_of_mem + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) hf + +/-- The corresponding comparison remains valid when the extended phase +ideal is reduced after base change. -/ +theorem map_baseContraction_le_geometricBaseContraction + (J : Ideal (SymbolRing k n)) : + (J.comap + (baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom).map + (scalarPolynomialMap (k := k) (K := K) (Fin n)) ≤ + (geometricRadicalExtension (k := k) (K := K) J).comap + (baseLift : MvPolynomial (Fin n) K →ₐ[K] SymbolRing K n).toRingHom := by + exact (map_baseContraction_le_extendedBaseContraction J).trans + (Ideal.comap_mono Ideal.le_radical) + +/-- A phase point of an extended ideal projects to a point of the contraction +of that extended ideal. -/ +theorem baseProjection_mem_zeroLocus_comap + (L : Ideal (SymbolRing K n)) (q : PhaseVar n → K) + (hq : q ∈ MvPolynomial.zeroLocus K L) : + (fun i ↦ q (Sum.inl i)) ∈ MvPolynomial.zeroLocus K + (L.comap + (baseLift : MvPolynomial (Fin n) K →ₐ[K] SymbolRing K n).toRingHom) := by + intro f hf + have h := hq (baseLift f) hf + change MvPolynomial.eval q (MvPolynomial.rename Sum.inl f) = 0 at h + rw [MvPolynomial.eval_rename] at h + exact h + +/-- Consequently, a geometric point of the reduced extension projects to a +zero of the scalar extension of the original base contraction. This is the +strong unconditional one-way base-contraction theorem. -/ +theorem geometricSupport_baseProjection_mem_groundContractionZeroLocus + (J : Ideal (SymbolRing k n)) (q : PhaseVar n → K) + (hq : q ∈ MvPolynomial.zeroLocus K + (geometricRadicalExtension (k := k) (K := K) J)) : + (fun i ↦ q (Sum.inl i)) ∈ MvPolynomial.zeroLocus K + ((J.comap + (baseLift : MvPolynomial (Fin n) k →ₐ[k] SymbolRing k n).toRingHom).map + (scalarPolynomialMap (k := k) (K := K) (Fin n))) := by + apply MvPolynomial.zeroLocus_anti_mono + (map_baseContraction_le_geometricBaseContraction J) + exact baseProjection_mem_zeroLocus_comap + (geometricRadicalExtension (k := k) (K := K) J) q hq + +/-- Exact membership in the equation-defined conormal locus after extending +the equation ideal. In particular, the base equations are evaluated by the +displayed `eval₂` map; no identification of closures across fields occurs. -/ +theorem mem_equationConormalLocus_map_iff + (I : Ideal (MvPolynomial (Fin n) k)) (q : PhaseVar n → K) : + q ∈ equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) ↔ + (∀ f ∈ I, + MvPolynomial.eval₂ (algebraMap k K) + (fun i ↦ q (Sum.inl i)) f = 0) ∧ + coordinateCovector (fun i ↦ q (Sum.inr i)) ∈ + affineConormalSpace (fun i ↦ q (Sum.inl i)) + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) := by + rw [equationConormalLocus] + constructor + · intro h + refine ⟨?_, h.2⟩ + exact (mem_zeroLocus_map_iff I (fun i ↦ q (Sum.inl i))).mp h.1 + · intro h + refine ⟨?_, h.2⟩ + exact (mem_zeroLocus_map_iff I (fun i ↦ q (Sum.inl i))).mpr h.1 + +/-- Partial derivatives commute with coefficient extension, with the +evaluation map at a geometric point shown explicitly. -/ +theorem differentialAt_scalarPolynomialMap + (y : Fin n → K) (f : MvPolynomial (Fin n) k) (i : Fin n) : + differentialAt y + (scalarPolynomialMap (k := k) (K := K) (Fin n) f) i = + MvPolynomial.eval₂ (algebraMap k K) y + (MvPolynomial.pderiv i f) := by + change MvPolynomial.eval y + (MvPolynomial.pderiv i + (MvPolynomial.map (algebraMap k K) f)) = _ + rw [MvPolynomial.pderiv_map, MvPolynomial.eval_map] + +/-- Once a pointwise conormal containment has been proved over `K`, its +`K`-valued algebraic closure hull remains in the reduced geometric support. +Both closure and reduction are taken after base change. -/ +theorem equationConormalClosure_map_subset_geometricRadicalExtension + (I : Ideal (MvPolynomial (Fin n) k)) + (J : Ideal (SymbolRing k n)) + (h : equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) ⊆ + MvPolynomial.zeroLocus K + (geometricRadicalExtension (k := k) (K := K) J)) : + equationConormalClosure + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) ⊆ + MvPolynomial.zeroLocus K + (geometricRadicalExtension (k := k) (K := K) J) := by + exact zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + (equationConormalLocus + (I.map (scalarPolynomialMap (k := k) (K := K) (Fin n))) ) + (geometricRadicalExtension (k := k) (K := K) J) h + +/-- The project-facing specialization: geometric reduction of the reduced +order-support ideal. This is intentionally `radical (map ...)`. -/ +def geometricReducedOrderSupportIdeal + (W : RightIdeal (PresentedWeyl k n)) : Ideal (SymbolRing K n) := + geometricRadicalExtension (k := k) (K := K) + (reducedOrderSupportIdeal k W) + +/-- The actual base contraction of the post-base-change reduced support. -/ +def geometricReducedOrderBaseIdeal + (W : RightIdeal (PresentedWeyl k n)) : + Ideal (MvPolynomial (Fin n) K) := + (geometricReducedOrderSupportIdeal (k := k) (K := K) W).comap + (baseLift : MvPolynomial (Fin n) K →ₐ[K] SymbolRing K n).toRingHom + +/-- Geometric points of the reduced order support are exactly the `K`-points +annihilating every ground-field reduced-support equation. -/ +theorem mem_zeroLocus_geometricReducedOrderSupportIdeal_iff + (W : RightIdeal (PresentedWeyl k n)) (q : PhaseVar n → K) : + q ∈ MvPolynomial.zeroLocus K + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) ↔ + ∀ f ∈ reducedOrderSupportIdeal k W, + MvPolynomial.eval₂ (algebraMap k K) q f = 0 := by + exact mem_zeroLocus_geometricRadicalExtension_iff + (reducedOrderSupportIdeal k W) q + +/-- Fibre-zero specialization commutes with coefficient extension. -/ +theorem scalarPolynomialMap_fibreZeroSpecialization + (P : SymbolRing k n) : + scalarPolynomialMap (k := k) (K := K) (Fin n) + (fibreZeroSpecialization k P) = + fibreZeroSpecialization K + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) P) := by + simp only [fibreZeroSpecialization, scalarPolynomialMap, + MvPolynomial.map_bind₁] + congr 1 + ext i + rcases i with i | i <;> simp + +private abbrev orderDecompositionExtension := + MvPolynomial.weightedHomogeneousSubmodule k (@orderWeight n) + +local instance orderGradedAlgebraExtensionInstance : + GradedAlgebra (orderDecompositionExtension (k := k) (n := n)) := + MvPolynomial.weightedGradedAlgebra k (@orderWeight n) + +/-- A geometric zero of the actual contracted reduced support lifts to the +zero section of the actual geometric reduced support. The proof transports +the ground-field degree-zero component through coefficient extension; it +does not identify the two base contractions. -/ +theorem zeroSection_mem_of_mem_geometricReducedOrderBaseZeroSet + (W : RightIdeal (PresentedWeyl k n)) (y : Fin n → K) + (hy : ∀ f ∈ geometricReducedOrderBaseIdeal (k := k) (K := K) W, + MvPolynomial.eval y f = 0) : + zeroSectionPoint y ∈ MvPolynomial.zeroLocus K + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) := by + rw [mem_zeroLocus_geometricReducedOrderSupportIdeal_iff] + intro P hP + obtain ⟨m, hm⟩ := (mem_reducedOrderSupportIdeal_iff k W P).mp hP + let f := fibreZeroSpecialization k (P ^ m) + have hcomponent : + (DirectSum.decompose + (orderDecompositionExtension (k := k) (n := n)) (P ^ m) 0 : + SymbolRing k n) ∈ orderInitialIdeal k W := + coe_mem_orderInitialIdeal_of_mem_orderSymbolRelation k W 0 + (DirectSum.decompose + (orderDecompositionExtension (k := k) (n := n)) (P ^ m) 0) + (decompose_mem_orderSymbolRelation_of_mem_orderInitialIdeal + k W (P ^ m) hm 0) + have hbaseLift : baseLift f ∈ reducedOrderSupportIdeal k W := by + rw [← zeroComponent_eq_baseLift_fibreZeroSpecialization] + exact orderInitialIdeal_le_reducedOrderSupportIdeal k W hcomponent + have hmapBase : + scalarPolynomialMap (k := k) (K := K) (Fin n) f ∈ + geometricReducedOrderBaseIdeal (k := k) (K := K) W := by + change baseLift + (scalarPolynomialMap (k := k) (K := K) (Fin n) f) ∈ + geometricReducedOrderSupportIdeal (k := k) (K := K) W + rw [← scalarPolynomialMap_baseLift] + exact Ideal.le_radical + (Ideal.mem_map_of_mem + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n)) hbaseLift) + have hfy : + MvPolynomial.eval y + (scalarPolynomialMap (k := k) (K := K) (Fin n) f) = 0 := + hy _ hmapBase + have heval : + MvPolynomial.eval (zeroSectionPoint y) + ((scalarPolynomialMap (k := k) (K := K) (PhaseVar n) P) ^ m) = 0 := by + rw [← map_pow, + ← eval_fibreZeroSpecialization K y + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) (P ^ m)), + ← scalarPolynomialMap_fibreZeroSpecialization] + exact hfy + have hp0 : + MvPolynomial.eval (zeroSectionPoint y) + (scalarPolynomialMap (k := k) (K := K) (PhaseVar n) P) = 0 := by + exact (pow_eq_zero_iff'.mp (by simpa only [map_pow] using heval)).1 + simpa [eval_scalarPolynomialMap] using hp0 + +/-- Exact geometric conormal consumer for the scalar-extended reduced order +support. The sole substantive hypothesis left to the caller is the +base-relative Poisson condition on the post-base-change radical ideal. -/ +theorem equationConormalClosure_geometricReducedOrderBase_subset_support + [CharZero K] + (W : RightIdeal (PresentedWeyl k n)) + (hJ : IsBaseRelativePoisson + (geometricReducedOrderSupportIdeal (k := k) (K := K) W)) : + equationConormalClosure + (geometricReducedOrderBaseIdeal (k := k) (K := K) W) ⊆ + MvPolynomial.zeroLocus K + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) := by + apply zeroLocus_vanishingIdeal_mono_of_subset_zeroLocus + intro q hq + let y : Fin n → K := fun i ↦ q (Sum.inl i) + let ξ : Fin n → K := fun i ↦ q (Sum.inr i) + have hzero := zeroSection_mem_of_mem_geometricReducedOrderBaseZeroSet + W y hq.1 + have hpoint := affineConormal_coordinatePoint_isCommonZero + (geometricReducedOrderSupportIdeal (k := k) (K := K) W) hJ y + hzero + (geometricReducedOrderBaseIdeal (k := k) (K := K) W) + (fun f ↦ f.2) ξ hq.2 + have hsplit : Sum.elim y ξ = q := by + funext i + rcases i with i | i <;> rfl + rw [← hsplit] + exact hpoint + + +end + +end Stafford38.Geometry.ScalarExtensionPoints diff --git a/LeanPool/Stafford38/Stafford38/Geometry/SeparableResidueDerivationExtension.lean b/LeanPool/Stafford38/Stafford38/Geometry/SeparableResidueDerivationExtension.lean new file mode 100644 index 0000000000..029c351d56 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/SeparableResidueDerivationExtension.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.RingTheory.Etale.Field +import Mathlib.RingTheory.Etale.Kaehler + +/-! +# Extending residue-field derivations through a separable extension + +Let `k -> E -> K` be a tower of fields and suppose that `K/E` is separable. +Formal etaleness identifies the Kahler differentials of `K/k` with the base +change to `K` of the differentials of `E/k`. Dualizing gives an exact linear +equivalence + +`Der_k(K, K) = Der_k(E, K)`. + +Thus every `k`-derivation of the relative coefficient field, after mapping its +values into the boundary residue field, extends uniquely to that residue +field. This is the derivation-extension part of the higher-dimensional +boundary-chart producer. + +This file does not construct a coefficient-field section of a complete DVR, +identify a completion with `K[[t]]`, or extend these derivations continuously +to power series. Those remain separate inputs to the completed-chart step. +-/ + +namespace Stafford38.Geometry.SeparableResidueDerivationExtension + +open TensorProduct + +noncomputable section + +universe u + +variable (k E K : Type u) +variable [Field k] [Field E] [Field K] +variable [Algebra k E] [Algebra k K] [Algebra E K] +variable [IsScalarTower k E K] +variable [Algebra.IsSeparable E K] + +/-- Extend a `k`-derivation `E -> K` uniquely through the separable field +extension `K/E`. The construction is the dual of the formally-etale base +change equivalence for Kahler differentials. -/ +noncomputable def extendDerivation + (D : Derivation k E K) : Derivation k K K := by + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + let base : K ⊗[E] KaehlerDifferential k E →ₗ[K] K := + D.liftKaehlerDifferential.liftBaseChange K + let pull : KaehlerDifferential k K →ₗ[K] K := + base.comp + (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale + k E K).symm.toLinearMap + exact KaehlerDifferential.linearMapEquivDerivation k K pull + +/-- Restricting the extended derivation to `E` recovers the supplied +`E -> K` derivation exactly. -/ +@[simp] +theorem extendDerivation_compAlgebraMap + (D : Derivation k E K) : + (extendDerivation k E K D).compAlgebraMap E = D := by + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + apply Derivation.ext + intro e + simp [extendDerivation, + KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_symm_D_algebraMap, + Derivation.liftKaehlerDifferential_comp_D] + +/-- A `k`-derivation of `K` is determined by its restriction to `E` when +`K/E` is separable. -/ +theorem derivation_ext_of_compAlgebraMap_eq + {D₁ D₂ : Derivation k K K} + (h : D₁.compAlgebraMap E = D₂.compAlgebraMap E) : + D₁ = D₂ := by + letI : Algebra.FormallyEtale E K := + Algebra.FormallyEtale.of_isSeparable E K + let e := KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale k E K + have hbase : + (D₁.liftKaehlerDifferential.restrictScalars E).comp + (KaehlerDifferential.map k k E K) = + (D₂.liftKaehlerDifferential.restrictScalars E).comp + (KaehlerDifferential.map k k E K) := by + apply Derivation.liftKaehlerDifferential_unique + apply Derivation.ext + intro x + simpa [KaehlerDifferential.map_D, + Derivation.liftKaehlerDifferential_comp_D] using + Derivation.congr_fun h x + have hpull : + D₁.liftKaehlerDifferential.comp e.toLinearMap = + D₂.liftKaehlerDifferential.comp e.toLinearMap := by + apply LinearMap.ext + intro z + induction z using TensorProduct.induction_on with + | zero => simp + | add x y hx hy => simp only [map_add, hx, hy] + | tmul a x => + simp only [e, + KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_apply, + KaehlerDifferential.mapBaseChange_tmul, + LinearMap.comp_apply, LinearEquiv.coe_coe, LinearMap.map_smul] + exact congrArg (a • ·) (LinearMap.congr_fun hbase x) + apply Derivation.ext + intro x + have hmaps : D₁.liftKaehlerDifferential = D₂.liftKaehlerDifferential := by + apply LinearMap.ext + intro w + obtain ⟨z, rfl⟩ := e.surjective w + exact LinearMap.congr_fun hpull z + simpa [Derivation.liftKaehlerDifferential_comp_D] using + LinearMap.congr_fun hmaps (KaehlerDifferential.D k K x) + +/-- Existence and uniqueness in the direct form used by the boundary tower. -/ +theorem existsUnique_derivation_extension + (D : Derivation k E K) : + ∃! D' : Derivation k K K, D'.compAlgebraMap E = D := by + refine ⟨extendDerivation k E K D, + extendDerivation_compAlgebraMap k E K D, ?_⟩ + intro D' hD' + apply derivation_ext_of_compAlgebraMap_eq k E K + rw [hD', extendDerivation_compAlgebraMap] + +/-- Restriction of derivations along `E -> K`, as a `K`-linear map. -/ +def restrictDerivation : + Derivation k K K →ₗ[K] Derivation k E K where + toFun D := D.compAlgebraMap E + map_add' _ _ := by ext; rfl + map_smul' _ _ := by ext; rfl + +/-- Restriction is a linear equivalence for a separable field extension. In +particular, finite derivation frames can be transported without losing linear +relations. -/ +noncomputable def derivationRestrictionEquiv : + Derivation k K K ≃ₗ[K] Derivation k E K := + LinearEquiv.ofBijective (restrictDerivation k E K) ⟨ + (fun _ _ h ↦ derivation_ext_of_compAlgebraMap_eq k E K h), + (fun D ↦ ⟨extendDerivation k E K D, + extendDerivation_compAlgebraMap k E K D⟩)⟩ + +@[simp] +theorem derivationRestrictionEquiv_apply + (D : Derivation k K K) : + derivationRestrictionEquiv k E K D = D.compAlgebraMap E := + rfl + +/-- Specialization to a derivation whose values initially lie in `E`. -/ +noncomputable def extendCoefficientDerivation + (D : Derivation k E E) : Derivation k K K := + extendDerivation k E K ((Algebra.linearMap E K).compDer D) + +@[simp] +theorem extendCoefficientDerivation_compAlgebraMap + (D : Derivation k E E) : + (extendCoefficientDerivation k E K D).compAlgebraMap E = + (Algebra.linearMap E K).compDer D := by + exact extendDerivation_compAlgebraMap k E K _ + + +end + +end Stafford38.Geometry.SeparableResidueDerivationExtension diff --git a/LeanPool/Stafford38/Stafford38/Geometry/SmoothAffineConormal.lean b/LeanPool/Stafford38/Stafford38/Geometry/SmoothAffineConormal.lean new file mode 100644 index 0000000000..68426fa332 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/SmoothAffineConormal.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ConormalPrincipalOpenDensity +import LeanPool.Stafford38.Stafford38.Geometry.GenericSmoothOpen + +/-! +# Density of the conormal over the smooth affine locus + +For a prime affine variety over an algebraically closed field, its genuine +Mathlib smooth points contain a nonempty principal open. Consequently the +equation conormal over those smooth points has the same algebraic closure as +the full equation conormal. +-/ + +namespace Stafford38.Geometry.SmoothAffineConormal + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ConormalPrincipalOpenDensity + +noncomputable section + +variable {k : Type*} [Field k] [IsAlgClosed k] {n : ℕ} + +def SmoothAffinePoint (I : Ideal (MvPolynomial (Fin n) k)) + (y : Fin n → k) : Prop := + ∃ e : (MvPolynomial (Fin n) k ⧸ I) →ₐ[k] k, + (∀ p, e (Ideal.Quotient.mk I p) = MvPolynomial.aeval y p) ∧ + let hprime : (RingHom.ker e.toRingHom).IsPrime := RingHom.ker_isPrime e + (⟨RingHom.ker e.toRingHom, hprime⟩ : + PrimeSpectrum (MvPolynomial (Fin n) k ⧸ I)) ∈ + Algebra.smoothLocus k (MvPolynomial (Fin n) k ⧸ I) + +theorem smoothAffinePoint_mem_zeroLocus + (I : Ideal (MvPolynomial (Fin n) k)) : + {y | SmoothAffinePoint I y} ⊆ MvPolynomial.zeroLocus k I := by + intro y hy p hp + obtain ⟨e, heval, _⟩ := hy + have hmk : Ideal.Quotient.mk I p = 0 := + Ideal.Quotient.eq_zero_iff_mem.mpr hp + rw [← heval p, hmk, map_zero] + +theorem equationConormalClosure_smoothAffine_eq + (I : Ideal (MvPolynomial (Fin n) k)) (hI : I.IsPrime) : + MvPolynomial.zeroLocus k + (MvPolynomial.vanishingIdeal k + (restrictedEquationConormalLocus I {y | SmoothAffinePoint I y})) = + equationConormalClosure I := by + letI : I.IsPrime := hI + letI : Algebra.FinitePresentation k (MvPolynomial (Fin n) k ⧸ I) := + Algebra.FinitePresentation.quotient I.fg_of_isNoetherianRing + obtain ⟨fbar, hfbar, hsmooth⟩ := exists_nonzero_smooth_away_quotient I + obtain ⟨f, rfl⟩ := Ideal.Quotient.mk_surjective fbar + have hf : f ∉ I := by + intro h + exact hfbar (Ideal.Quotient.eq_zero_iff_mem.mpr h) + apply equationConormalClosure_restricted_eq I hI f hf + {y | SmoothAffinePoint I y} + (smoothAffinePoint_mem_zeroLocus I) + intro y hyI hyf + let e : (MvPolynomial (Fin n) k ⧸ I) →ₐ[k] k := + Ideal.Quotient.liftₐ I (MvPolynomial.aeval y) (by + intro p hp + exact hyI p hp) + refine ⟨e, ?_, ?_⟩ + · intro p + simp [e] + · have hopen : (⟨RingHom.ker e.toRingHom, RingHom.ker_isPrime e⟩ : + PrimeSpectrum (MvPolynomial (Fin n) k ⧸ I)) ∈ + PrimeSpectrum.basicOpen (Ideal.Quotient.mk I f) := by + rw [PrimeSpectrum.mem_basicOpen] + intro hker + have hezero : e (Ideal.Quotient.mk I f) = 0 := hker + simp [e] at hezero + exact hyf hezero + exact (Algebra.basicOpen_subset_smoothLocus_iff_smooth.mpr hsmooth) hopen + + +end +end Stafford38.Geometry.SmoothAffineConormal diff --git a/LeanPool/Stafford38/Stafford38/Geometry/SmoothConormalFibreVanishing.lean b/LeanPool/Stafford38/Stafford38/Geometry/SmoothConormalFibreVanishing.lean new file mode 100644 index 0000000000..5923f7d84e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/SmoothConormalFibreVanishing.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.ProjectiveConormalDirections +import LeanPool.Stafford38.Stafford38.Geometry.LaurentConormalDirection + +/-! +# Fibre equations of the smooth conormal closure + +For a prime affine ideal, a fibre polynomial vanishing on all smooth conormal +fibres also vanishes on the entire equation-conormal locus. +-/ + +namespace Stafford38.Geometry.SmoothConormalFibreVanishing + +open Stafford38.Geometry.AffineConormalClosure +open Stafford38.Geometry.ConormalPrincipalOpenDensity +open Stafford38.Geometry.SmoothAffineConormal +open Stafford38.Geometry.ProjectiveConormalDirections +open Stafford38.Geometry.LaurentConormalDirection + +noncomputable section + +theorem fibreLift_mem_vanishingIdeal_equationConormal + {k : Type*} [Field k] [IsAlgClosed k] {n : ℕ} + (I : Ideal (MvPolynomial (Fin n) k)) (hI : I.IsPrime) + (P : MvPolynomial (Fin n) k) + (hP : P ∈ MvPolynomial.vanishingIdeal k (smoothConormalFibreProjection I)) : + fibreLift P ∈ MvPolynomial.vanishingIdeal k (equationConormalLocus I) := by + intro q hq + have hclosure : q ∈ equationConormalClosure I := by + intro f hf + exact hf q hq + rw [← equationConormalClosure_smoothAffine_eq I hI] at hclosure + apply hclosure + intro r hr + have hproj : (fun i => r (.inr i)) ∈ smoothConormalFibreProjection I := + ⟨fun i => r (.inl i), hr.2, hr.1.2⟩ + have hv := hP _ hproj + simpa [fibreLift, MvPolynomial.eval_rename, Function.comp_def] using hv + + +end +end Stafford38.Geometry.SmoothConormalFibreVanishing diff --git a/LeanPool/Stafford38/Stafford38/Geometry/SplitTangentMatrix.lean b/LeanPool/Stafford38/Stafford38/Geometry/SplitTangentMatrix.lean new file mode 100644 index 0000000000..2055cceb44 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Geometry/SplitTangentMatrix.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Geometry.PowerSeriesTangentLimit + +/-! +# Splitting a rectangular power-series matrix from a selected minor + +Let `B` be a matrix whose columns are indexed by `κ`. An embedding +`rows : κ ↪ ι` selects a square minor of `B`. If the determinant of that +minor is a unit, its nonsingular inverse, followed by the row-selector matrix, +is an explicit left inverse of `B`. + +For matrices over `k[[X]]`, it is enough to assume that the determinant of the +selected minor has nonzero constant coefficient. This file does not assert +that a suitable minor exists for a geometric tangent family. +-/ + +namespace Stafford38.GeometrySplitTangentMatrix + +noncomputable section + +universe u v + +variable {R : Type u} [CommRing R] + +/-- The square submatrix obtained by retaining the explicitly selected rows. -/ +def selectedMinor {ι κ : Type*} (B : Matrix ι κ R) (rows : κ ↪ ι) : Matrix κ κ R := + fun a b => B (rows a) b + +/-- The matrix which restricts a column indexed by `ι` to the selected rows. -/ +def rowSelector {ι κ : Type*} [DecidableEq ι] (rows : κ ↪ ι) : Matrix κ ι R := + fun a i => if rows a = i then 1 else 0 + +theorem rowSelector_mul + {ι κ : Type*} [Fintype ι] [DecidableEq ι] + (B : Matrix ι κ R) (rows : κ ↪ ι) : + rowSelector (R := R) rows * B = selectedMinor B rows := by + ext a b + simp [Matrix.mul_apply, rowSelector, selectedMinor] + +/-- +The constructive left inverse supplied by an invertible selected minor. + +The nonsingular inverse is the adjugate divided by the determinant in +Mathlib's matrix API; no inverse of the rectangular matrix is used. +-/ +def selectedMinorLeftInverse + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ R) (rows : κ ↪ ι) : Matrix κ ι R := + (selectedMinor B rows)⁻¹ * rowSelector (R := R) rows + +/-- A unit determinant of the selected square minor makes the construction a +left inverse of the original rectangular matrix. -/ +theorem selectedMinorLeftInverse_mul + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ R) (rows : κ ↪ ι) + (hdet : IsUnit (selectedMinor B rows).det) : + selectedMinorLeftInverse B rows * B = 1 := by + rw [selectedMinorLeftInverse, Matrix.mul_assoc, rowSelector_mul] + exact Matrix.nonsing_inv_mul _ hdet + +/-- The selected-minor construction, packaged as an explicit split matrix. -/ +theorem exists_leftInverse_of_selectedMinor_det_isUnit + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ R) (rows : κ ↪ ι) + (hdet : IsUnit (selectedMinor B rows).det) : + ∃ C : Matrix κ ι R, C * B = 1 := + ⟨selectedMinorLeftInverse B rows, + selectedMinorLeftInverse_mul B rows hdet⟩ + +/-! ## Power-series criterion -/ + +variable {k : Type v} [Field k] + +/-- Over `k[[X]]`, a nonzero constant coefficient makes the selected +determinant a unit and hence gives the same explicit left inverse. -/ +theorem powerSeries_selectedMinorLeftInverse_mul + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) + (hconst : PowerSeries.constantCoeff (selectedMinor B rows).det ≠ 0) : + selectedMinorLeftInverse B rows * B = 1 := by + apply selectedMinorLeftInverse_mul + rw [PowerSeries.isUnit_iff_constantCoeff] + exact isUnit_iff_ne_zero.mpr hconst + +/-- Existence form used by the tangent-limit annihilator construction. -/ +theorem powerSeries_exists_leftInverse_of_selectedMinor_constantCoeff_ne_zero + {ι κ : Type*} [Fintype ι] [Fintype κ] + [DecidableEq ι] [DecidableEq κ] + (B : Matrix ι κ (PowerSeries k)) (rows : κ ↪ ι) + (hconst : PowerSeries.constantCoeff (selectedMinor B rows).det ≠ 0) : + ∃ C : Matrix κ ι (PowerSeries k), C * B = 1 := + ⟨selectedMinorLeftInverse B rows, + powerSeries_selectedMinorLeftInverse_mul B rows hconst⟩ + + +end + +end Stafford38.GeometrySplitTangentMatrix diff --git a/LeanPool/Stafford38/Stafford38/LeftDenominatorTransport.lean b/LeanPool/Stafford38/Stafford38/LeftDenominatorTransport.lean new file mode 100644 index 0000000000..9ec1f8a50a --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LeftDenominatorTransport.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.LocalizationCorollaries + +namespace Stafford38.LocalizationCorollaries + +theorem s38_of_leftUnitClearing + {R : Type u} {L : Type v} [Ring R] [Ring L] + {f : R →+* L} (hR : S38 R) + (hclear : ∀ q : L, q ≠ 0 → + ∃ a : R, ∃ u : L, IsUnit u ∧ u * q = f a) : S38 L := + AlgebraicAnalysis.TwoGeneratorIdentity.of_leftUnitClearing hR hclear + + +end Stafford38.LocalizationCorollaries diff --git a/LeanPool/Stafford38/Stafford38/LeftHandedCorollary.lean b/LeanPool/Stafford38/Stafford38/LeftHandedCorollary.lean new file mode 100644 index 0000000000..abbec54e3b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LeftHandedCorollary.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Statement +import LeanPool.Stafford38.Stafford38.Weyl.TranspositionFiltration + +/-! The left-handed form is the formal-adjoint/opposite-ring image of the + written-order Stafford identity. -/ + +namespace Stafford38.LeftHandedCorollary + +open Stafford38 +open Stafford38.WeylTransposition +open Stafford38.WeylTranspositionFiltration + +universe u + +def LeftHandedStatement : Prop := + ∀ (k : Type u) [Field k] [CharZero k] (n : ℕ) (d : WeylAlg k n), + d ≠ 0 → ∃ R S F : WeylAlg k n, + (1 : WeylAlg k n) = R * d + S * d * F + +theorem leftHanded_of_universalStatement + (h : UniversalStatement.{u}) : LeftHandedStatement.{u} := by + intro k _ _ n d hd + have htd : transpose k n d ≠ 0 := by + intro hz + apply hd + simpa only [transpose_transpose, transpose_zero] using congrArg (transpose k n) hz + rcases h k n (transpose k n d) htd with ⟨F, R, S, hone⟩ + refine ⟨transpose k n R, transpose k n S, transpose k n F, ?_⟩ + have ht := congrArg (transpose k n) hone + have h1 : transpose k n (1 : WeylAlg k n) = 1 := by simp [transpose] + rw [h1] at ht + simpa [transpose_add, transpose_mul, transpose_transpose, mul_assoc] using ht + +end Stafford38.LeftHandedCorollary diff --git a/LeanPool/Stafford38/Stafford38/LocalizationCorollaries.lean b/LeanPool/Stafford38/Stafford38/LocalizationCorollaries.lean new file mode 100644 index 0000000000..3be1c72771 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizationCorollaries.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Statement +import LeanPool.Stafford38.AlgebraicAnalysis.RingTheory.TwoGeneratorIdentity +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightLocalization + +/-! Right Ore localization corollaries for the Stafford 3.8 identity. +The generic unit-denominator transport proof lives in AlgebraicAnalysis. -/ + +namespace Stafford38.LocalizationCorollaries + +universe u v + +abbrev S38 := AlgebraicAnalysis.TwoGeneratorIdentity + +/-- A fraction-clearing formulation sufficient to transport `S38`. The unit +condition concerns only the denominator chosen for the given fraction. -/ +theorem s38_of_rightClearing + {R : Type u} {L : Type v} [Ring R] [Ring L] + {f : R →+* L} (hR : S38 R) + (hclear : ∀ q : L, q ≠ 0 → + ∃ a s : R, IsUnit (f s) ∧ q * f s = f a) : S38 L := + AlgebraicAnalysis.TwoGeneratorIdentity.of_rightUnitClearing hR hclear + +/- Compatibility exports for the reusable right Ore localization API. -/ +export AlgebraicAnalysis.OreRightLocalization + (oppositeSubmonoid RightOreLocalization rightNumeratorRingHom rightOre_clear) + +/-- Stafford 3.8 is preserved by genuine right Ore localization. -/ +theorem s38_rightOreLocalization + {R : Type u} [Ring R] {S : Submonoid R} + [OreLocalization.OreSet (oppositeSubmonoid S)] + (hR : S38 R) : S38 (RightOreLocalization R S) := + AlgebraicAnalysis.TwoGeneratorIdentity.of_rightOreLocalization hR + + +end Stafford38.LocalizationCorollaries diff --git a/LeanPool/Stafford38/Stafford38/LocalizedDifferentialClearing.lean b/LeanPool/Stafford38/Stafford38/LocalizedDifferentialClearing.lean new file mode 100644 index 0000000000..80a3ad55fe --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizedDifferentialClearing.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.LocalizedWeylAction +import LeanPool.Stafford38.Stafford38.CoordinateDifferentialGeneration +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialCommutant + +namespace Stafford38.LocalizedDifferentialClearing + +open Stafford +open Stafford38.DifferentialOperators +open Stafford38.LocalizedPolynomialDerivations +open Stafford38.LocalizedWeylAction +open Stafford38.LocalizedPolynomialCommutant +open Stafford38.CoordinateDifferentialGeneration +open Stafford38.WeylIteratedEquivalence + +noncomputable section +universe u + +variable {k : Type u} [Field k] [CharZero k] {n : ℕ} +variable (S : Submonoid (MvPolynomial (Fin n) k)) +variable (B : Type u) [CommRing B] +variable [Algebra (MvPolynomial (Fin n) k) B] [Algebra k B] +variable [IsScalarTower k (MvPolynomial (Fin n) k) B] +variable [IsLocalization S B] + +abbrev A := MvPolynomial (Fin n) k +abbrev D := DifferentialOperators.algebra (k := k) (R := B) + +def weylEnd (a : PresentedWeyl k n) : Module.End k B := + (localizedWeylAction S B a : Module.End k B) + +def actionSpan : Submodule B (Module.End k B) := + Submodule.span B (Set.range (weylEnd S B)) + +private theorem actionSpan_mem (a : PresentedWeyl k n) : + weylEnd S B a ∈ actionSpan S B := + Submodule.subset_span ⟨a, rfl⟩ + +private theorem actionSpan_smul_eq_multiplication (b : B) : + b • weylEnd S B 1 = multiplication (k := k) b := by + ext x + simp [weylEnd, multiplication_apply, Algebra.smul_def] + +private theorem actionSpan_mul_right_generator + (i : Fin n) (a : PresentedWeyl k n) : + weylEnd S B a * (localizedPderiv S B i).toLinearMap ∈ actionSpan S B := by + change (localizedWeylAction S B a : Module.End k B) * + (differentialGenerator S B (.inr i) : Module.End k B) ∈ actionSpan S B + rw [← localizedWeylAction_generator S B (.inr i)] + have hm := congrArg (fun q : D (k := k) B => + (q : Module.End k B)) + ((localizedWeylAction S B).map_mul a + (freeWeylGenerator (Matrix.J (Fin n) k) (.inr i))) + have hm' : weylEnd S B + (a * freeWeylGenerator (Matrix.J (Fin n) k) (.inr i)) = + weylEnd S B a * weylEnd S B + (freeWeylGenerator (Matrix.J (Fin n) k) (.inr i)) := by + simpa [weylEnd] using hm + change weylEnd S B a * weylEnd S B + (freeWeylGenerator (Matrix.J (Fin n) k) (.inr i)) ∈ actionSpan S B + rw [← hm'] + exact actionSpan_mem S B _ + +private theorem actionSpan_right_stable + (i : Fin n) {Q : Module.End k B} (hQ : Q ∈ actionSpan S B) : + Q * (localizedPderiv S B i).toLinearMap ∈ actionSpan S B := by + refine Submodule.span_induction ?_ ?_ ?_ ?_ hQ + · rintro Q ⟨a, rfl⟩ + exact actionSpan_mul_right_generator S B i a + · simp + · intro x y hx hy hxr hyr + rw [add_mul] + exact (actionSpan S B).add_mem hxr hyr + · intro c x hx hxr + rw [smul_mul_assoc] + exact (actionSpan S B).smul_mem c hxr + +theorem actual_differential_mem_actionSpan + (P : Module.End k B) + (hP : P ∈ D (k := k) B) : P ∈ actionSpan S B := by + refine mem_submodule_of_coordinates + (fun i : Fin n => algebraMap (A (k := k) (n := n)) B (MvPolynomial.X i)) + (fun i => localizedPderiv S B i) + (H := (actionSpan S B).restrictScalars k) + ?_ ?_ ?_ ?_ P hP + · intro i j + exact localizedPderiv_apply_algebraMap_X S B i j + · intro Q hQ + apply eq_multiplication_of_commute_coordinate B S Q + intro i b + have hi := LinearMap.congr_fun (hQ i) b + exact sub_eq_zero.mp (by simpa [commutator_apply] using hi) + · intro b + rw [← actionSpan_smul_eq_multiplication S B b] + exact (actionSpan S B).smul_mem b (actionSpan_mem S B 1) + · intro i Q hQ + exact actionSpan_right_stable S B i hQ + +theorem localized_differential_mem_actionSpan + (P : D (k := k) B) : + (P : Module.End k B) ∈ actionSpan S B := + actual_differential_mem_actionSpan S B P (P.property) + +private theorem multiplication_algebraMap_in_action + (f : A (k := k) (n := n)) : + ∃ a : PresentedWeyl k n, + weylEnd S B a = multiplication (algebraMap (A (k := k) (n := n)) B f) := by + induction f using MvPolynomial.induction_on with + | C c => + refine ⟨algebraMap k (PresentedWeyl k n) c, ?_⟩ + have hc : algebraMap (A (k := k) (n := n)) B (MvPolynomial.C c) = + algebraMap k B c := by + calc + _ = algebraMap (A (k := k) (n := n)) B + (algebraMap k (A (k := k) (n := n)) c) := by + rw [MvPolynomial.algebraMap_eq] + _ = algebraMap k B c := by + exact (IsScalarTower.algebraMap_apply k + (A (k := k) (n := n)) B c).symm + ext b + simp [weylEnd, multiplication_apply, Algebra.smul_def, hc] + | add f g hf hg => + obtain ⟨a, ha⟩ := hf + obtain ⟨b, hb⟩ := hg + refine ⟨a + b, ?_⟩ + have hadd : weylEnd S B (a + b) = weylEnd S B a + weylEnd S B b := by + simp [weylEnd] + rw [hadd, ha, hb] + ext z + simp [multiplication_apply] + ring + | mul_X f i hf => + obtain ⟨a, ha⟩ := hf + let Xweyl := freeWeylGenerator (Matrix.J (Fin n) k) (.inl i) + refine ⟨Xweyl * a, ?_⟩ + have hX : weylEnd S B Xweyl = + multiplication (algebraMap (A (k := k) (n := n)) B + (MvPolynomial.X i)) := by + ext z + simp [Xweyl, weylEnd, differentialGenerator, coordinateEnd, + multiplication_apply] + have hmul := congrArg (fun q : D (k := k) B => (q : Module.End k B)) + ((localizedWeylAction S B).map_mul Xweyl a) + rw [show weylEnd S B (Xweyl * a) = weylEnd S B Xweyl * weylEnd S B a by + simpa [weylEnd] using hmul] + rw [hX, ha] + ext z + simp [multiplication_apply, Module.End.mul_apply, map_mul, mul_assoc] + ring + +/-- A common denominator on the left clears every intrinsic differential +operator on a localization of a polynomial ring. -/ +theorem actual_differential_left_denominator_clearing + (P : Module.End k B) (hP : P ∈ D (k := k) B) : + ∃ s : S, ∃ a : PresentedWeyl k n, + multiplication (algebraMap (A (k := k) (n := n)) B (s : A)) * P = + weylEnd S B a := by + have hspan := actual_differential_mem_actionSpan S B P hP + refine Submodule.span_induction ?_ ?_ ?_ ?_ hspan + · rintro Q ⟨a, rfl⟩ + refine ⟨1, a, ?_⟩ + ext z + simp [multiplication_apply, Module.End.mul_apply] + · refine ⟨1, 0, ?_⟩ + ext z + simp [multiplication_apply, weylEnd] + · intro Q T hQ hT hcQ hcT + obtain ⟨s, a, ha⟩ := hcQ + obtain ⟨t, b, hb⟩ := hcT + obtain ⟨pt, hpt⟩ := multiplication_algebraMap_in_action S B (t : A) + obtain ⟨ps, hps⟩ := multiplication_algebraMap_in_action S B (s : A) + refine ⟨s * t, pt * a + ps * b, ?_⟩ + have hact_mul (c d : PresentedWeyl k n) : + weylEnd S B (c * d) = weylEnd S B c * weylEnd S B d := by + have h := congrArg (fun q : D (k := k) B => (q : Module.End k B)) + ((localizedWeylAction S B).map_mul c d) + simpa [weylEnd] using h + have hact_add (c d : PresentedWeyl k n) : + weylEnd S B (c + d) = weylEnd S B c + weylEnd S B d := by + simp [weylEnd] + rw [hact_add, hact_mul, hact_mul, hpt, hps, ← ha, ← hb] + ext z + simp [multiplication_apply, Module.End.mul_apply, map_mul] + ring + · intro c Q hQ hcQ + obtain ⟨s, a, ha⟩ := hcQ + obtain ⟨⟨r, u⟩, hu⟩ := IsLocalization.surj S c + obtain ⟨pr, hpr⟩ := multiplication_algebraMap_in_action S B r + refine ⟨u * s, pr * a, ?_⟩ + have hact_mul : weylEnd S B (pr * a) = + weylEnd S B pr * weylEnd S B a := by + have h := congrArg (fun q : D (k := k) B => (q : Module.End k B)) + ((localizedWeylAction S B).map_mul pr a) + simpa [weylEnd] using h + rw [hact_mul, hpr, ← ha] + ext z + simp only [Module.End.mul_apply, multiplication_apply, LinearMap.smul_apply, + Algebra.smul_def, Submonoid.coe_mul, map_mul] + change algebraMap (MvPolynomial (Fin n) k) B (u : MvPolynomial (Fin n) k) * + algebraMap (MvPolynomial (Fin n) k) B (s : MvPolynomial (Fin n) k) * + (c * Q z) = + algebraMap (MvPolynomial (Fin n) k) B r * + (algebraMap (MvPolynomial (Fin n) k) B + (s : MvPolynomial (Fin n) k) * Q z) + rw [← hu] + ring + +theorem localized_differential_left_denominator_clearing + (P : D (k := k) B) : + ∃ s : S, ∃ a : PresentedWeyl k n, + multiplication (algebraMap (A (k := k) (n := n)) B (s : A)) * + (P : Module.End k B) = weylEnd S B a := + actual_differential_left_denominator_clearing S B P P.property + +end +end Stafford38.LocalizedDifferentialClearing diff --git a/LeanPool/Stafford38/Stafford38/LocalizedDifferentialCorollaries.lean b/LeanPool/Stafford38/Stafford38/LocalizedDifferentialCorollaries.lean new file mode 100644 index 0000000000..fc8b3786cd --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizedDifferentialCorollaries.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.LocalizedDifferentialClearing +import LeanPool.Stafford38.Stafford38.LeftDenominatorTransport +import LeanPool.Stafford38.Stafford38.FoundationClosure + +namespace Stafford38.LocalizedDifferentialCorollaries + +open Stafford +open Stafford38.DifferentialOperators +open Stafford38.LocalizedWeylAction +open Stafford38.LocalizedDifferentialClearing +open Stafford38.LocalizationCorollaries +open Stafford38.WeylIteratedEquivalence + +noncomputable section +universe u + +variable {k : Type u} [Field k] [CharZero k] {n : ℕ} +variable (S : Submonoid (MvPolynomial (Fin n) k)) +variable (B : Type u) [CommRing B] +variable [Algebra (MvPolynomial (Fin n) k) B] [Algebra k B] +variable [IsScalarTower k (MvPolynomial (Fin n) k) B] +variable [IsLocalization S B] + +abbrev A := MvPolynomial (Fin n) k +abbrev D := DifferentialOperators.algebra (k := k) (R := B) + +def multiplicationD (b : B) : D (k := k) B := + ⟨multiplication (k := k) b, + ⟨0, (mem_order_zero_iff_eq_multiplication _).2 (by + ext x + simp [multiplication_apply])⟩⟩ + +private theorem multiplicationD_mul (b c : B) : + multiplicationD (k := k) (B := B) b * multiplicationD (k := k) (B := B) c = + multiplicationD (k := k) (B := B) (b * c) := by + apply Subtype.ext + ext x + simp [multiplicationD, multiplication_apply, mul_assoc] + +private theorem multiplicationD_one : multiplicationD (k := k) (B := B) (1 : B) = + (1 : D (k := k) B) := by + apply Subtype.ext + ext x + simp [multiplicationD, multiplication_apply] + +private theorem multiplicationD_isUnit {b : B} (hb : IsUnit b) : + IsUnit (multiplicationD (k := k) (B := B) b) := by + rcases hb with ⟨u, hu⟩ + refine ⟨⟨multiplicationD (k := k) (B := B) b, + multiplicationD (k := k) (B := B) u.inv, ?_, ?_⟩, rfl⟩ + · have h : b * u.inv = 1 := by rw [← hu]; exact u.val_inv + rw [multiplicationD_mul, h, multiplicationD_one] + · have h : u.inv * b = 1 := by rw [← hu]; exact u.inv_val + rw [multiplicationD_mul, h, multiplicationD_one] + +include S in +theorem s38_localized_differential + (hS : S38 (PresentedWeyl k n)) : S38 (D (k := k) B) := by + apply s38_of_leftUnitClearing hS + intro q hq + obtain ⟨s, a, ha⟩ := localized_differential_left_denominator_clearing S B q + let b : B := algebraMap (A (k := k) (n := n)) B (s : A) + have hb : IsUnit b := IsLocalization.map_units B s + refine ⟨a, multiplicationD (k := k) (B := B) b, + multiplicationD_isUnit (k := k) (B := B) hb, ?_⟩ + apply Subtype.ext + change multiplication (k := k) b * (q : Module.End k B) = weylEnd S B a + exact ha + +theorem s38_principal_localized_differential + (f : A (k := k) (n := n)) + (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsLocalization (Submonoid.powers f) B] + (hS : S38 (PresentedWeyl k n)) : + S38 (D (k := k) B) := by + exact s38_localized_differential (Submonoid.powers f) B hS + +theorem s38_unconditional_localized_differential + (S : Submonoid (A (k := k) (n := n))) + (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsLocalization S B] : + S38 (D (k := k) B) := by + apply s38_localized_differential S B + intro d hd + exact Stafford38.universalStatement (k := k) n d hd + +theorem s38_fraction_ring_differential + (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsFractionRing (A (k := k) (n := n)) B] : + S38 (D (k := k) B) := by + apply s38_localized_differential + (nonZeroDivisors (A (k := k) (n := n))) B + intro d hd + exact Stafford38.universalStatement (k := k) n d hd + +def allCoordinateProduct : A (k := k) (n := n) := + Finset.univ.prod (fun i : Fin n => MvPolynomial.X i) + +theorem s38_laurent_differential + (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsLocalization (Submonoid.powers + (allCoordinateProduct (k := k) (n := n))) B] : + S38 (D (k := k) B) := by + apply s38_localized_differential + (Submonoid.powers (allCoordinateProduct (k := k) (n := n))) B + intro d hd + exact Stafford38.universalStatement (k := k) n d hd + + +theorem s38_principal_open_differential + (f : A (k := k) (n := n)) + (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsLocalization (Submonoid.powers f) B] : + S38 (D (k := k) B) := + s38_unconditional_localized_differential (Submonoid.powers f) B + +theorem s38_partial_laurent_differential + (J : Finset (Fin n)) (B : Type u) [CommRing B] + [Algebra (A (k := k) (n := n)) B] [Algebra k B] + [IsScalarTower k (A (k := k) (n := n)) B] + [IsLocalization (Submonoid.powers + (J.prod (fun i => (MvPolynomial.X i : A (k := k) (n := n)))) ) B] : + S38 (D (k := k) B) := + s38_unconditional_localized_differential + (Submonoid.powers (J.prod (fun i => + (MvPolynomial.X i : A (k := k) (n := n))))) B + + +end +end Stafford38.LocalizedDifferentialCorollaries diff --git a/LeanPool/Stafford38/Stafford38/LocalizedPolynomialCommutant.lean b/LeanPool/Stafford38/Stafford38/LocalizedPolynomialCommutant.lean new file mode 100644 index 0000000000..6bccf18c57 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizedPolynomialCommutant.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant + +/-! Compatibility export for the reusable localized polynomial commutant. -/ +namespace Stafford38.LocalizedPolynomialCommutant + +export AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialCommutant + (eq_multiplication_of_commute_coordinate) + +end Stafford38.LocalizedPolynomialCommutant diff --git a/LeanPool/Stafford38/Stafford38/LocalizedPolynomialDerivations.lean b/LeanPool/Stafford38/Stafford38/LocalizedPolynomialDerivations.lean new file mode 100644 index 0000000000..e89d81c2c1 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizedPolynomialDerivations.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations + +/-! Compatibility exports for reusable localized polynomial derivations. -/ +namespace Stafford38.LocalizedPolynomialDerivations + +export AlgebraicAnalysis.DifferentialOperators.LocalizedPolynomialDerivations + (extendDerivation extendDerivation_compAlgebraMap derivation_ext_of_compAlgebraMap_eq + PolynomialRing localizedPderiv localizedPderiv_compAlgebraMap + localizedPderiv_apply_algebraMap_X localizedPderiv_comm) + +end Stafford38.LocalizedPolynomialDerivations diff --git a/LeanPool/Stafford38/Stafford38/LocalizedWeylAction.lean b/LeanPool/Stafford38/Stafford38/LocalizedWeylAction.lean new file mode 100644 index 0000000000..858089435d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/LocalizedWeylAction.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.LocalizedPolynomialDerivations +import LeanPool.Stafford38.Stafford38.DifferentialOperators +import LeanPool.Stafford38.Stafford38.Weyl.Universal +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence + +/-! +# The Weyl action on a polynomial localization + +This file constructs the Weyl action on the genuine finite-order differential +operators of a localization of a polynomial ring. No identification of the +resulting differential-operator algebra with another presentation is used. +-/ + +namespace Stafford38.LocalizedWeylAction + +open Stafford +open Stafford38.DifferentialOperators +open Stafford38.LocalizedPolynomialDerivations +open Stafford38.WeylUniversal +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable {k : Type u} [Field k] {n : ℕ} +variable (S : Submonoid (MvPolynomial (Fin n) k)) +variable (B : Type u) [CommRing B] +variable [Algebra (MvPolynomial (Fin n) k) B] [Algebra k B] +variable [IsScalarTower k (MvPolynomial (Fin n) k) B] +variable [IsLocalization S B] + +abbrev A := MvPolynomial (Fin n) k +abbrev D (B : Type u) [CommRing B] [Algebra k B] := + algebra (k := k) (R := B) + +def coordinateEnd (i : Fin n) : End (k := k) (R := B) := + multiplication (algebraMap (A (k := k) (n := n)) B (MvPolynomial.X i)) + +def momentumEnd (i : Fin n) : End (k := k) (R := B) := + (localizedPderiv S B i).toLinearMap + +theorem coordinateEnd_mem_order_zero (i : Fin n) : + coordinateEnd (B := B) i ∈ order (k := k) (R := B) 0 := by + rw [mem_order_zero_iff_eq_multiplication] + ext x + simp [coordinateEnd, multiplication_apply] + +theorem momentumEnd_mem_order_one (i : Fin n) : + momentumEnd S B i ∈ order (k := k) (R := B) 1 := by + rw [show 1 = 0 + 1 by rfl, mem_order_succ_iff] + intro a + rw [mem_order_zero_iff_eq_multiplication] + apply LinearMap.ext + intro x + change localizedPderiv S B i (a * x) - a * localizedPderiv S B i x = _ + rw [(localizedPderiv S B i).leibniz] + simp [DifferentialOperators.commutator_apply, multiplication_apply, + momentumEnd, mul_comm, add_comm] + +def differentialGenerator : (Fin n ⊕ Fin n) → D (k := k) B + | .inl i => ⟨coordinateEnd (B := B) i, 0, + coordinateEnd_mem_order_zero (B := B) i⟩ + | .inr i => ⟨momentumEnd S B i, 1, momentumEnd_mem_order_one S B i⟩ + +theorem differentialGenerator_commutator (i j : Fin n ⊕ Fin n) : + Stafford.commutator (differentialGenerator S B i) + (differentialGenerator S B j) = + algebraMap k (D (k := k) B) (Matrix.J (Fin n) k i j) := by + apply Subtype.ext + apply LinearMap.ext + intro f + cases i with + | inl i => + cases j with + | inl j => simp [Stafford.commutator, differentialGenerator, + coordinateEnd, Module.End.mul_apply, Matrix.J, mul_comm, mul_assoc, + mul_left_comm] + | inr j => + by_cases h : i = j + · subst j + simp [Stafford.commutator, differentialGenerator, coordinateEnd, + momentumEnd, Module.End.mul_apply, Matrix.J, + localizedPderiv_apply_algebraMap_X] + · simp [Stafford.commutator, differentialGenerator, coordinateEnd, + momentumEnd, Module.End.mul_apply, Matrix.J, h, + Ne.symm h, localizedPderiv_apply_algebraMap_X] + | inr i => + cases j with + | inl j => + by_cases h : i = j + · subst j + simp [Stafford.commutator, differentialGenerator, coordinateEnd, + momentumEnd, Module.End.mul_apply, Matrix.J, + localizedPderiv_apply_algebraMap_X] + · simp [Stafford.commutator, differentialGenerator, coordinateEnd, + momentumEnd, differentialGenerator, coordinateEnd, + Matrix.J, h, localizedPderiv_apply_algebraMap_X] + | inr j => + have hc := localizedPderiv_comm S B i j + have hcf := LinearMap.congr_fun hc f + simpa [Stafford.commutator, differentialGenerator, momentumEnd, + Module.End.mul_apply, Matrix.J] using (sub_eq_zero.mpr hcf) + +def localizedWeylAction : + PresentedWeyl k n →ₐ[k] D (k := k) B := + freeWeylLift (Matrix.J (Fin n) k) (differentialGenerator S B) + (differentialGenerator_commutator S B) + +@[simp] theorem localizedWeylAction_generator (i : Fin n ⊕ Fin n) : + localizedWeylAction S B + (freeWeylGenerator (Matrix.J (Fin n) k) i) = + differentialGenerator S B i := + freeWeylLift_generator _ _ _ i + +theorem localizedWeylAction_mem (a : PresentedWeyl k n) : + (localizedWeylAction S B a : End (k := k) (R := B)) ∈ D (k := k) B := + (localizedWeylAction S B a).property + +include S +theorem multiplication_algebraMap_mem_range (f : A (k := k) (n := n)) : + ∃ P : D (k := k) B, (P : End (k := k) (R := B)) = + multiplication (algebraMap (A (k := k) (n := n)) B f) := by + induction f using MvPolynomial.induction_on with + | C c => + refine ⟨algebraMap k (D (k := k) B) c, ?_⟩ + ext x + have hc : algebraMap (A (k := k) (n := n)) B (MvPolynomial.C c) = + algebraMap k B c := by + calc + _ = algebraMap (A (k := k) (n := n)) B + (algebraMap k (A (k := k) (n := n)) c) := by + rw [MvPolynomial.algebraMap_eq] + _ = algebraMap k B c := by + exact (IsScalarTower.algebraMap_apply k + (A (k := k) (n := n)) B c).symm + rw [hc] + simp [multiplication_apply, Algebra.smul_def] + | add f g hf hg => + obtain ⟨P, hP⟩ := hf + obtain ⟨Q, hQ⟩ := hg + refine ⟨P + Q, ?_⟩ + ext x + simp [hP, hQ, multiplication_apply, map_add, add_mul] + | mul_X f i hf => + obtain ⟨P, hP⟩ := hf + refine ⟨(differentialGenerator S B (.inl i)) * P, ?_⟩ + ext x + change algebraMap (A (k := k) (n := n)) B (MvPolynomial.X i) * + (P : End (k := k) (R := B)) x = _ + rw [hP] + simp [multiplication_apply, map_mul, mul_assoc] + ring + + +end +end Stafford38.LocalizedWeylAction diff --git a/LeanPool/Stafford38/Stafford38/Ore/CoordinateStage.lean b/LeanPool/Stafford38/Stafford38/Ore/CoordinateStage.lean new file mode 100644 index 0000000000..901df0db7c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/CoordinateStage.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity + +/-! +# The central-coordinate Ore stage + +The zero-derivation Ore product is ordinary polynomial multiplication. This +identifies the first stage in the recursive Weyl construction with a central +polynomial extension and transports ordinary differentiation to it. +-/ + +namespace Stafford38.OreCoordinateStage + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + +variable {B : Type*} [Ring B] + +/-- The zero derivation on a ring. -/ +def zeroDerivation : OreDivisionDerivation B where + toFun := 0 + map_zero' := rfl + map_add' := by simp + leibniz' := by simp + +@[simp] theorem zeroDerivation_apply (b : B) : zeroDerivation b = 0 := rfl + +@[simp] theorem zeroDerivation_iterate_succ (n : ℕ) (b : B) : + ((zeroDerivation : B → B)^[n + 1]) b = 0 := by + rw [Function.iterate_succ_apply'] + rfl + +theorem rightTerm_zeroDerivation (i : ℕ) (a b : B) (j : ℕ) : + rightTerm zeroDerivation i a b j = monomial (i + j) (a * b) := by + rw [rightTerm, Finset.sum_eq_single 0] + · simp + · intro k hk hk0 + have hkpos : 0 < k := Nat.pos_of_ne_zero hk0 + obtain ⟨l, rfl⟩ := Nat.exists_eq_add_of_le hkpos + have hzero : ((zeroDerivation : B → B)^[1 + l]) b = 0 := by + rw [Nat.add_comm] + exact zeroDerivation_iterate_succ l b + rw [hzero, nsmul_zero, mul_zero, monomial_zero_right] + · simp + +theorem rightMulMonomial_zeroDerivation (p : Polynomial B) (b : B) (j : ℕ) : + rightMulMonomial zeroDerivation p b j = p * monomial j b := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [rightMulMonomial_add_left, hp, hq, add_mul] + | monomial i a => + rw [rightMulMonomial, + Polynomial.sum_monomial_index a _ (rightTerm_zero zeroDerivation i b j)] + rw [rightTerm_zeroDerivation, monomial_mul_monomial] + +/-- With zero derivation, the Ore normal-form product is the ordinary central +polynomial product, even for a noncommutative coefficient ring. -/ +theorem rightMul_zeroDerivation_eq_mul (p q : Polynomial B) : + rightMul zeroDerivation p q = p * q := by + induction q using Polynomial.induction_on' with + | add q r hq hr => + rw [rightMul_add, hq, hr, mul_add] + | monomial j b => + rw [rightMul_monomial, rightMulMonomial_zeroDerivation] + +/-- The central-coordinate extension of `B`. -/ +abbrev CoordinateStage := NormalOre (zeroDerivation : OreDivisionDerivation B) + +@[simp] theorem normalForm_mul_zeroDerivation (p q : Polynomial B) : + normalForm zeroDerivation (p * q) = + normalForm zeroDerivation p * normalForm zeroDerivation q := by + rw [← rightMul_zeroDerivation_eq_mul, normalForm_mul] + +@[simp] theorem normalFormAddEquiv_symm_normalForm (p : Polynomial B) : + (normalFormAddEquiv zeroDerivation).symm (normalForm zeroDerivation p) = p := by + rw [show normalForm zeroDerivation p = + (normalFormAddEquiv zeroDerivation) p by rfl] + exact (normalFormAddEquiv zeroDerivation).symm_apply_apply p + +/-- Ordinary polynomial differentiation, transported to the central Ore +stage. -/ +def coordinateDerivation : OreDivisionDerivation (CoordinateStage (B := B)) where + toFun z := normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm z)) + map_zero' := by + change normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm 0)) = 0 + rw [(normalFormAddEquiv zeroDerivation).symm.map_zero, + Polynomial.derivative_zero, normalForm_zero] + map_add' z w := by + have h := (normalFormAddEquiv zeroDerivation).symm.toAddHom.map_add z w + change (normalFormAddEquiv zeroDerivation).symm (z + w) = + (normalFormAddEquiv zeroDerivation).symm z + + (normalFormAddEquiv zeroDerivation).symm w at h + change normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm (z + w))) = + normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm z)) + + normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm w)) + rw [h, Polynomial.derivative_add, normalForm_add] + leibniz' := by + intro z w + rcases normalForm_surjective zeroDerivation z with ⟨p, rfl⟩ + rcases normalForm_surjective zeroDerivation w with ⟨q, rfl⟩ + rw [← normalForm_mul_zeroDerivation] + change normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm + (normalForm zeroDerivation (p * q)))) = + normalForm zeroDerivation p * + normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm + (normalForm zeroDerivation q))) + + normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm + (normalForm zeroDerivation p))) * + normalForm zeroDerivation q + rw [normalFormAddEquiv_symm_normalForm, + normalFormAddEquiv_symm_normalForm, normalFormAddEquiv_symm_normalForm] + rw [Polynomial.derivative_mul, normalForm_add, + normalForm_mul_zeroDerivation, normalForm_mul_zeroDerivation] + exact add_comm _ _ + +@[simp] theorem coordinateDerivation_normalForm (p : Polynomial B) : + coordinateDerivation (normalForm zeroDerivation p) = + normalForm zeroDerivation (Polynomial.derivative p) := by + change normalForm zeroDerivation + (Polynomial.derivative ((normalFormAddEquiv zeroDerivation).symm + (normalForm zeroDerivation p))) = _ + rw [normalFormAddEquiv_symm_normalForm] + +@[simp] theorem coordinateDerivation_coefficient (b : B) : + coordinateDerivation (normalCoefficient zeroDerivation b) = 0 := by + rw [← normalForm_C, coordinateDerivation_normalForm, + Polynomial.derivative_C, normalForm_zero] + +@[simp] theorem coordinateDerivation_variable : + coordinateDerivation (normalVariable zeroDerivation : CoordinateStage (B := B)) = 1 := by + rw [normalVariable, coordinateDerivation_normalForm, + Polynomial.derivative_X, normalForm_one] + + +end +end Stafford38.OreCoordinateStage diff --git a/LeanPool/Stafford38/Stafford38/Ore/IteratedPairStage.lean b/LeanPool/Stafford38/Stafford38/Ore/IteratedPairStage.lean new file mode 100644 index 0000000000..375efed19e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/IteratedPairStage.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Ore.PairStage + +/-! +# Iterated coordinate-momentum pair stages + +This file recursively repeats the checked `PairStage` construction over an +arbitrary coefficient ring. It records only the resulting tower and the +canonical data introduced at each successor; it does not identify the tower +with a presented Weyl algebra. +-/ + +namespace Stafford38.OreIteratedPairStage + +open Stafford38.OrePairStage + +noncomputable section + +universe u + +/-- A type together with the ring structure used at the next Ore stage. -/ +private structure RingStage where + carrier : Type u + ring : Ring carrier + +variable (B : Type u) [Ring B] + +/-- The recursively constructed ring data after adjoining `n` Weyl pairs. -/ +private def iteratedPairData : Nat → RingStage + | 0 => ⟨B, inferInstance⟩ + | n + 1 => + let previous := iteratedPairData n + letI : Ring previous.carrier := previous.ring + ⟨PairStage (B := previous.carrier), inferInstance⟩ + +/-- The ring obtained from `B` after recursively adjoining `n` checked +coordinate-momentum pairs. -/ +def IteratedPairStage (n : Nat) : Type u := + (iteratedPairData B n).carrier + +instance iteratedPairStageRing (n : Nat) : Ring (IteratedPairStage B n) := + (iteratedPairData B n).ring + +/-- The zeroth stage is the original coefficient type. -/ +theorem iteratedPairStage_zero : IteratedPairStage B 0 = B := rfl + +/-- Every successor is definitionally the checked `PairStage` construction +over its predecessor. -/ +theorem iteratedPairStage_succ (n : Nat) : + IteratedPairStage B (n + 1) = + PairStage (B := IteratedPairStage B n) := rfl + +/-- The canonical embedding from stage `n` into stage `n + 1`. -/ +def stageEmbedding (n : Nat) : + IteratedPairStage B n →+* IteratedPairStage B (n + 1) := + pairCoefficient (B := IteratedPairStage B n) + +/-- The coordinate introduced at the successor of stage `n`. -/ +def stageCoordinate (n : Nat) : IteratedPairStage B (n + 1) := + pairCoordinate (B := IteratedPairStage B n) + +/-- The momentum introduced at the successor of stage `n`. -/ +def stageMomentum (n : Nat) : IteratedPairStage B (n + 1) := + pairMomentum (B := IteratedPairStage B n) + +/-- The coordinate introduced at stage `n + 1` commutes with the embedded +predecessor ring. -/ +theorem stageCoordinate_mul_embedding (n : Nat) + (b : IteratedPairStage B n) : + stageCoordinate B n * stageEmbedding B n b = + stageEmbedding B n b * stageCoordinate B n := + pairCoordinate_mul_coefficient b + +/-- The momentum introduced at stage `n + 1` commutes with the embedded +predecessor ring. -/ +theorem stageMomentum_mul_embedding (n : Nat) + (b : IteratedPairStage B n) : + stageMomentum B n * stageEmbedding B n b = + stageEmbedding B n b * stageMomentum B n := + pairMomentum_mul_coefficient b + +/-- The generators introduced at stage `n + 1` satisfy the checked Weyl +relation. -/ +theorem stageMomentum_mul_coordinate (n : Nat) : + stageMomentum B n * stageCoordinate B n = + stageCoordinate B n * stageMomentum B n + 1 := + pairMomentum_mul_coordinate + + +end + +end Stafford38.OreIteratedPairStage diff --git a/LeanPool/Stafford38/Stafford38/Ore/LinearNormalForm.lean b/LeanPool/Stafford38/Stafford38/Ore/LinearNormalForm.lean new file mode 100644 index 0000000000..5d0c296829 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/LinearNormalForm.lean @@ -0,0 +1,337 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Ore.ScalarAlgebra +import LeanPool.Stafford38.Stafford38.Ore.PairStage +import Mathlib.Algebra.MvPolynomial.Equiv +import Mathlib.Algebra.Polynomial.AlgebraMap + +/-! +# Scalar-linear Ore normal forms + +The additive normal-form equivalence is linear over every central scalar ring +killed by the coefficient derivation. This is the scalar interface needed to +turn the iterated Ore normal form into a PBW basis. +-/ + +namespace Stafford38.OreLinearNormalForm + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open Stafford38.OreScalarAlgebra +open Stafford38.OreCoordinateStage +open Stafford38.OrePairStage + +noncomputable section + +/-- Polynomials are linearly equivalent to their coefficient finsupps. -/ +def polynomialFinsuppLinearEquiv + {k R : Type*} [CommSemiring k] [Semiring R] [Algebra k R] : + Polynomial R ≃ₗ[k] (ℕ →₀ R) := + { (Polynomial.toFinsuppIso R).toAddEquiv.trans + (AddMonoidAlgebra.coeffLinearEquiv k).toAddEquiv with + map_smul' := by + intro c p + rfl } + +/-- Apply a linear equivalence independently to every polynomial +coefficient. -/ +def polynomialMapRangeLinearEquiv + {k R S : Type*} [CommSemiring k] [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) : + Polynomial R ≃ₗ[k] Polynomial S := + (polynomialFinsuppLinearEquiv (k := k) (R := R)).trans + ((Finsupp.mapRange.linearEquiv e).trans + (polynomialFinsuppLinearEquiv (k := k) (R := S)).symm) + +@[simp] theorem polynomialMapRangeLinearEquiv_C + {k R S : Type*} [CommSemiring k] [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) (r : R) : + polynomialMapRangeLinearEquiv e (Polynomial.C r) = + Polynomial.C (e r) := by + apply (Polynomial.toFinsuppIso S).injective + simp [polynomialMapRangeLinearEquiv, polynomialFinsuppLinearEquiv] + +@[simp] theorem polynomialMapRangeLinearEquiv_monomial + {k R S : Type*} [CommSemiring k] [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) (n : ℕ) (r : R) : + polynomialMapRangeLinearEquiv e (Polynomial.monomial n r) = + Polynomial.monomial n (e r) := by + apply (Polynomial.toFinsuppIso S).injective + simp [polynomialMapRangeLinearEquiv, polynomialFinsuppLinearEquiv] + +@[simp] theorem polynomialMapRangeLinearEquiv_X + {k R S : Type*} [CommSemiring k] [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) + (h1 : e 1 = 1) : + polynomialMapRangeLinearEquiv e Polynomial.X = Polynomial.X := by + apply (Polynomial.toFinsuppIso S).injective + simp [polynomialMapRangeLinearEquiv, polynomialFinsuppLinearEquiv, h1] + +@[simp] theorem polynomialMapRangeLinearEquiv_one + {k R S : Type*} [CommSemiring k] [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) + (h1 : e 1 = 1) : + polynomialMapRangeLinearEquiv e 1 = 1 := by + change polynomialMapRangeLinearEquiv e (Polynomial.C 1) = Polynomial.C 1 + rw [polynomialMapRangeLinearEquiv_C, h1] + +/-- A univariate polynomial is a multivariate polynomial in one `PUnit` +variable, linearly over any central ground ring. -/ +def univariateMvPolynomialLinearEquiv + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] : + Polynomial R ≃ₗ[k] MvPolynomial PUnit.{1} R := + ((MvPolynomial.pUnitAlgEquiv R).symm.toLinearEquiv).restrictScalars k + +@[simp] theorem univariateMvPolynomialLinearEquiv_C + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] (r : R) : + univariateMvPolynomialLinearEquiv (k := k) (R := R) (Polynomial.C r) = + MvPolynomial.C r := by + simp [univariateMvPolynomialLinearEquiv, MvPolynomial.pUnitAlgEquiv] + +@[simp] theorem univariateMvPolynomialLinearEquiv_X + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] : + univariateMvPolynomialLinearEquiv (k := k) (R := R) Polynomial.X = + MvPolynomial.X (PUnit.unit : PUnit.{1}) := by + simp [univariateMvPolynomialLinearEquiv, MvPolynomial.pUnitAlgEquiv] + +/-- Flatten two nested univariate polynomial layers into two commuting symbol +variables as an algebra equivalence over the coefficient ring. -/ +def nestedPolynomialAlgEquiv (R : Type*) [CommRing R] : + Polynomial (Polynomial R) ≃ₐ[R] + MvPolynomial (PUnit.{1} ⊕ PUnit.{1}) R := + (Polynomial.mapAlgEquiv ((MvPolynomial.pUnitAlgEquiv R).symm)).trans + ((((MvPolynomial.pUnitAlgEquiv (MvPolynomial PUnit.{1} R)).symm + ).restrictScalars R).trans + (MvPolynomial.sumAlgEquiv R PUnit.{1} PUnit.{1}).symm) + +/-- The scalar-linear form of `nestedPolynomialAlgEquiv`. -/ +def nestedPolynomialLinearEquiv + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] : + Polynomial (Polynomial R) ≃ₗ[k] + MvPolynomial (PUnit.{1} ⊕ PUnit.{1}) R := + (nestedPolynomialAlgEquiv R).toLinearEquiv.restrictScalars k + +@[simp] theorem nestedPolynomialLinearEquiv_constant + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] (r : R) : + nestedPolynomialLinearEquiv (k := k) (R := R) + (Polynomial.C (Polynomial.C r)) = MvPolynomial.C r := by + simp [nestedPolynomialLinearEquiv, nestedPolynomialAlgEquiv] + +@[simp] theorem nestedPolynomialLinearEquiv_coordinate + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] : + nestedPolynomialLinearEquiv (k := k) (R := R) + (Polynomial.C Polynomial.X) = + MvPolynomial.X (.inr (PUnit.unit : PUnit.{1})) := by + simp [nestedPolynomialLinearEquiv, nestedPolynomialAlgEquiv] + +@[simp] theorem nestedPolynomialLinearEquiv_momentum + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] : + nestedPolynomialLinearEquiv (k := k) (R := R) Polynomial.X = + MvPolynomial.X (.inl (PUnit.unit : PUnit.{1})) := by + simp [nestedPolynomialLinearEquiv, nestedPolynomialAlgEquiv] + +private theorem nestedPolynomialLinearEquiv_mul + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] + (f g : Polynomial (Polynomial R)) : + nestedPolynomialLinearEquiv (k := k) (R := R) (f * g) = + nestedPolynomialLinearEquiv (k := k) (R := R) f * + nestedPolynomialLinearEquiv (k := k) (R := R) g := by + change nestedPolynomialAlgEquiv R (f * g) = + nestedPolynomialAlgEquiv R f * nestedPolynomialAlgEquiv R g + exact map_mul (nestedPolynomialAlgEquiv R) f g + +private theorem nestedPolynomialLinearEquiv_pow + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] + (f : Polynomial (Polynomial R)) (n : ℕ) : + nestedPolynomialLinearEquiv (k := k) (R := R) (f ^ n) = + nestedPolynomialLinearEquiv (k := k) (R := R) f ^ n := by + change nestedPolynomialAlgEquiv R (f ^ n) = + nestedPolynomialAlgEquiv R f ^ n + exact map_pow (nestedPolynomialAlgEquiv R) f n + +/-- Nested univariate monomials become the two corresponding commuting symbol +powers, with the outer polynomial variable in the left summand. -/ +theorem nestedPolynomialLinearEquiv_monomial + {k R : Type*} [CommRing k] [CommRing R] [Algebra k R] + (r : R) (a p : ℕ) : + nestedPolynomialLinearEquiv (k := k) (R := R) + (Polynomial.monomial p (Polynomial.monomial a r)) = + MvPolynomial.X (.inl (PUnit.unit : PUnit.{1})) ^ p * + MvPolynomial.X (.inr (PUnit.unit : PUnit.{1})) ^ a * + MvPolynomial.C r := by + rw [← Polynomial.C_mul_X_pow_eq_monomial, + ← Polynomial.C_mul_X_pow_eq_monomial] + rw [show Polynomial.C (Polynomial.C r * Polynomial.X ^ a) = + Polynomial.C (Polynomial.C r) * + Polynomial.C Polynomial.X ^ a by rw [map_mul, map_pow]] + rw [nestedPolynomialLinearEquiv_mul, + nestedPolynomialLinearEquiv_mul, + nestedPolynomialLinearEquiv_pow, + nestedPolynomialLinearEquiv_pow, + nestedPolynomialLinearEquiv_constant, + nestedPolynomialLinearEquiv_coordinate, + nestedPolynomialLinearEquiv_momentum] + ring + +section OneVariable + +variable {k B : Type*} [CommRing k] [Ring B] [Algebra k B] +variable (D : OreDivisionDerivation B) +variable [Algebra k (NormalOre D)] +variable (hAlg : algebraMap k (NormalOre D) = + (normalCoefficient D).comp (algebraMap k B)) + +include hAlg + +/-- The coefficient-left normal-form map respects central scalar +multiplication. -/ +theorem normalForm_smul (c : k) (p : Polynomial B) : + normalForm D (c • p) = c • normalForm D p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [smul_add, normalForm_add, normalForm_add, hp, hq, + Algebra.smul_def, Algebra.smul_def, Algebra.smul_def, mul_add] + | monomial n b => + rw [Polynomial.smul_monomial, normalForm_monomial, + normalForm_monomial] + rw [Algebra.smul_def c b] + have hs : c • (normalCoefficient D b * normalVariable D ^ n) = + algebraMap k (NormalOre D) c * + (normalCoefficient D b * normalVariable D ^ n) := + Algebra.smul_def c _ + rw [hs, hAlg] + change normalCoefficient D (algebraMap k B c * b) * normalVariable D ^ n = + normalCoefficient D (algebraMap k B c) * + (normalCoefficient D b * normalVariable D ^ n) + rw [map_mul, mul_assoc] + +/-- Ore normal forms are linearly equivalent to ordinary coefficient-left +polynomials. -/ +def normalFormLinearEquiv : Polynomial B ≃ₗ[k] NormalOre D := + { normalFormAddEquiv D with + map_smul' := normalForm_smul D hAlg } + +@[simp] theorem normalFormLinearEquiv_apply (p : Polynomial B) : + normalFormLinearEquiv D hAlg p = normalForm D p := rfl + +@[simp] theorem normalFormLinearEquiv_symm_normalForm (p : Polynomial B) : + (normalFormLinearEquiv D hAlg).symm (normalForm D p) = p := + (normalFormLinearEquiv D hAlg).symm_apply_apply p + +@[simp] theorem normalFormLinearEquiv_symm_coefficient (b : B) : + (normalFormLinearEquiv D hAlg).symm (normalCoefficient D b) = + Polynomial.C b := by + rw [← normalForm_C, normalFormLinearEquiv_symm_normalForm] + +@[simp] theorem normalFormLinearEquiv_symm_variable : + (normalFormLinearEquiv D hAlg).symm (normalVariable D) = + Polynomial.X := by + rw [normalVariable, normalFormLinearEquiv_symm_normalForm] + +@[simp] theorem normalFormLinearEquiv_symm_one : + (normalFormLinearEquiv D hAlg).symm 1 = 1 := by + rw [← normalForm_one D, normalFormLinearEquiv_symm_normalForm] + +end OneVariable + +section Pair + + +/-- Expose the two coefficient-left polynomial layers of a pair stage and +apply a chosen linear coordinate system to the old coefficients. -/ +def pairNormalFormLinearEquiv + {k B S : Type*} [CommRing k] [Ring B] [Algebra k B] + [CommRing S] [Algebra k S] + [Algebra k (CoordinateStage (B := B))] + [Algebra k (PairStage (B := B))] + (hInner : algebraMap k (CoordinateStage (B := B)) = + (normalCoefficient zeroDerivation).comp (algebraMap k B)) + (hOuter : algebraMap k (PairStage (B := B)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := B)))) + (e : B ≃ₗ[k] S) : + PairStage (B := B) ≃ₗ[k] Polynomial (Polynomial S) := + (normalFormLinearEquiv coordinateDerivation hOuter).symm.trans + (polynomialMapRangeLinearEquiv + ((normalFormLinearEquiv zeroDerivation hInner).symm.trans + (polynomialMapRangeLinearEquiv e))) + +@[simp] theorem pairNormalFormLinearEquiv_coefficient + {k B S : Type*} [CommRing k] [Ring B] [Algebra k B] + [CommRing S] [Algebra k S] + [Algebra k (CoordinateStage (B := B))] + [Algebra k (PairStage (B := B))] + (hInner) (hOuter) (e : B ≃ₗ[k] S) (b : B) : + pairNormalFormLinearEquiv hInner hOuter e (pairCoefficient b) = + Polynomial.C (Polynomial.C (e b)) := by + simp [pairNormalFormLinearEquiv, pairCoefficient] + +@[simp] theorem pairNormalFormLinearEquiv_coordinate + {k B S : Type*} [CommRing k] [Ring B] [Algebra k B] + [CommRing S] [Algebra k S] + [Algebra k (CoordinateStage (B := B))] + [Algebra k (PairStage (B := B))] + (hInner) (hOuter) (e : B ≃ₗ[k] S) (h1 : e 1 = 1) : + pairNormalFormLinearEquiv hInner hOuter e pairCoordinate = + Polynomial.C Polynomial.X := by + simp [pairNormalFormLinearEquiv, pairCoordinate, + polynomialMapRangeLinearEquiv_X _ h1] + +@[simp] theorem pairNormalFormLinearEquiv_momentum + {k B S : Type*} [CommRing k] [Ring B] [Algebra k B] + [CommRing S] [Algebra k S] + [Algebra k (CoordinateStage (B := B))] + [Algebra k (PairStage (B := B))] + (hInner) (hOuter) (e : B ≃ₗ[k] S) (h1 : e 1 = 1) : + pairNormalFormLinearEquiv hInner hOuter e pairMomentum = + Polynomial.X := by + have hInnerOne : + ((normalFormLinearEquiv zeroDerivation hInner).symm.trans + (polynomialMapRangeLinearEquiv e)) 1 = 1 := by + simp [h1, polynomialMapRangeLinearEquiv_one] + simp [pairNormalFormLinearEquiv, pairMomentum, + polynomialMapRangeLinearEquiv_X _ hInnerOne] + +/-- The two-stage normal-form map sends a coefficient followed by powers of +the new coordinate and momentum to the corresponding nested monomial. -/ +@[simp] theorem pairNormalFormLinearEquiv_orderedMonomial + {k B S : Type*} [CommRing k] [Ring B] [Algebra k B] + [CommRing S] [Algebra k S] + [Algebra k (CoordinateStage (B := B))] + [Algebra k (PairStage (B := B))] + (hInner : algebraMap k (CoordinateStage (B := B)) = + (normalCoefficient zeroDerivation).comp (algebraMap k B)) + (hOuter : algebraMap k (PairStage (B := B)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := B)))) + (e : B ≃ₗ[k] S) (b : B) (a p : ℕ) : + pairNormalFormLinearEquiv hInner hOuter e + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ p) = + Polynomial.monomial p (Polynomial.monomial a (e b)) := by + have hnormal : + pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ p = + normalForm coordinateDerivation + (Polynomial.monomial p + (normalForm zeroDerivation (Polynomial.monomial a b))) := by + rw [normalForm_monomial, normalForm_monomial] + change + normalCoefficient coordinateDerivation (normalCoefficient zeroDerivation b) * + (normalCoefficient coordinateDerivation (normalVariable zeroDerivation)) ^ a * + normalVariable coordinateDerivation ^ p = _ + rw [map_mul, map_pow] + rw [hnormal] + simp [pairNormalFormLinearEquiv] + +end Pair + + +end + +end Stafford38.OreLinearNormalForm diff --git a/LeanPool/Stafford38/Stafford38/Ore/PairStage.lean b/LeanPool/Stafford38/Stafford38/Ore/PairStage.lean new file mode 100644 index 0000000000..ee00500347 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/PairStage.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.RightPBW +import Mathlib.LinearAlgebra.Basis.Basic +import LeanPool.Stafford38.Stafford38.Ore.ScalarAlgebra + +/-! +# A coordinate-momentum pair over a coefficient ring + +Two successive Ore extensions adjoin a central coordinate and then its +derivation momentum. This file packages the resulting three canonical +generator families and proves their exact relations. +-/ + +namespace Stafford38.OrePairStage + +open AlgebraicAnalysis +open AlgebraicAnalysis.OreAssociativity +open AlgebraicAnalysis.OreRightPBW +open Stafford38.OreCoordinateStage + +noncomputable section + +variable {B : Type*} [Ring B] + +/-- First adjoin a central coordinate, then a momentum differentiating it. -/ +abbrev PairStage := + NormalOre (coordinateDerivation : + OreDivisionDerivation (CoordinateStage (B := B))) + +private abbrev innerD : OreDivisionDerivation B := zeroDerivation + +private abbrev outerD : OreDivisionDerivation (CoordinateStage (B := B)) := + coordinateDerivation + +/-- Embed the old coefficient ring through both Ore stages. -/ +def pairCoefficient : B →+* PairStage (B := B) := + (normalCoefficient outerD).comp (normalCoefficient innerD) + +/-- The newly adjoined coordinate. -/ +def pairCoordinate : PairStage (B := B) := + normalCoefficient outerD (normalVariable innerD) + +/-- The newly adjoined momentum. -/ +def pairMomentum : PairStage (B := B) := + normalVariable outerD + +/-- The checked right PBW basis for the momentum stage over the coordinate +stage. This is a consumer of the reusable one-stage right-PBW interface; the +pair-specific generators and Weyl relation remain owned by Stafford38. -/ +def pairStage_rightOrePBWBasis [Nontrivial B] : + Module.Basis ℕ (CoordinateStage (B := B))ᵐᵒᵖ (PairStage (B := B)) := + rightOrePBWBasis coordinateDerivation + +/-- The new coordinate commutes with every old coefficient. -/ +theorem pairCoordinate_mul_coefficient (b : B) : + pairCoordinate * pairCoefficient b = pairCoefficient b * pairCoordinate := by + change + normalCoefficient outerD (normalVariable innerD) * + normalCoefficient outerD (normalCoefficient innerD b) = + normalCoefficient outerD (normalCoefficient innerD b) * + normalCoefficient outerD (normalVariable innerD) + rw [← (normalCoefficient outerD).map_mul, + ← (normalCoefficient outerD).map_mul] + congr 1 + have h := normalVariable_mul_coefficient innerD b + rw [zeroDerivation_apply, map_zero, add_zero] at h + exact h + +/-- The new momentum commutes with every old coefficient. -/ +theorem pairMomentum_mul_coefficient (b : B) : + pairMomentum * pairCoefficient b = pairCoefficient b * pairMomentum := by + change + normalVariable outerD * normalCoefficient outerD (normalCoefficient innerD b) = + normalCoefficient outerD (normalCoefficient innerD b) * normalVariable outerD + have h := normalVariable_mul_coefficient outerD (normalCoefficient innerD b) + rw [coordinateDerivation_coefficient, map_zero, add_zero] at h + exact h + +/-- The new pair satisfies the Weyl relation in the manuscript convention. -/ +theorem pairMomentum_mul_coordinate : + pairMomentum (B := B) * pairCoordinate = + pairCoordinate * pairMomentum + 1 := by + change + normalVariable outerD * normalCoefficient outerD (normalVariable innerD) = + normalCoefficient outerD (normalVariable innerD) * normalVariable outerD + 1 + have h := normalVariable_mul_coefficient outerD + (normalVariable innerD : CoordinateStage (B := B)) + rw [coordinateDerivation_variable, map_one] at h + exact h + +theorem pairCoordinate_commutator_momentum : + pairCoordinate (B := B) * pairMomentum - pairMomentum * pairCoordinate = -1 := by + rw [pairMomentum_mul_coordinate] + noncomm_ring + +section Scalars + +variable {k : Type*} [CommRing k] [Algebra k B] + +/-- The scalar algebra structure on the central-coordinate stage. -/ +def coordinateStageAlgebra : Algebra k (CoordinateStage (B := B)) := + Stafford38.OreScalarAlgebra.normalOreAlgebra innerD fun c => by + exact zeroDerivation_apply (algebraMap k B c) + +theorem coordinateDerivation_algebraMap (c : k) : + @coordinateDerivation B _ + (@algebraMap k (CoordinateStage (B := B)) _ _ coordinateStageAlgebra c) = 0 := by + change coordinateDerivation + (normalCoefficient innerD (algebraMap k B c)) = 0 + exact coordinateDerivation_coefficient (algebraMap k B c) + +/-- The scalar algebra structure on the full coordinate-momentum pair. -/ +def pairStageAlgebra : Algebra k (PairStage (B := B)) := by + letI : Algebra k (CoordinateStage (B := B)) := coordinateStageAlgebra + exact Stafford38.OreScalarAlgebra.normalOreAlgebra outerD + coordinateDerivation_algebraMap + +theorem pairStageAlgebra_algebraMap : + @algebraMap k (PairStage (B := B)) _ _ pairStageAlgebra = + (pairCoefficient (B := B)).comp (algebraMap k B) := rfl + +end Scalars + + +end +end Stafford38.OrePairStage diff --git a/LeanPool/Stafford38/Stafford38/Ore/PairUniversal.lean b/LeanPool/Stafford38/Stafford38/Ore/PairUniversal.lean new file mode 100644 index 0000000000..76d4a5117b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/PairUniversal.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Ore.PairStage + +/-! +# Universal property of a coordinate-momentum pair stage + +The construction is the universal property of `NormalOre` applied twice. +First a coefficient map and a commuting coordinate define a map from the +central-coordinate stage. A momentum satisfying the derivation relation +against that map then defines a map from `PairStage`. +-/ + +namespace Stafford38.OrePairUniversal + +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open Stafford38.OreCoordinateStage +open Stafford38.OrePairStage + +noncomputable section + +variable {B A : Type*} [Ring B] [Ring A] + +/-- The Ore ambient determined by a coefficient map and a centralizing +coordinate image. -/ +def coordinateAmbient (f : B →+* A) (X : A) + (hX : ∀ b, X * f b = f b * X) : + OreAmbient B A (zeroDerivation : OreDivisionDerivation B) where + embed := f + x := X + relation := by + intro b + simpa using hX b + +/-- The universal map from the central-coordinate stage. -/ +def coordinateLift (f : B →+* A) (X : A) + (hX : ∀ b, X * f b = f b * X) : + CoordinateStage (B := B) →+* A := + oreLift zeroDerivation (coordinateAmbient f X hX) + +@[simp] theorem coordinateLift_coefficient (f : B →+* A) (X : A) + (hX : ∀ b, X * f b = f b * X) (b : B) : + coordinateLift f X hX (normalCoefficient zeroDerivation b) = f b := + oreLift_coefficient zeroDerivation (coordinateAmbient f X hX) b + +@[simp] theorem coordinateLift_variable (f : B →+* A) (X : A) + (hX : ∀ b, X * f b = f b * X) : + coordinateLift f X hX (normalVariable zeroDerivation) = X := + oreLift_variable zeroDerivation (coordinateAmbient f X hX) + +/-- A map out of the coordinate stage is determined by the old coefficients +and the new coordinate. -/ +theorem coordinateLift_unique (f : B →+* A) (X : A) + (hX : ∀ b, X * f b = f b * X) + (g : CoordinateStage (B := B) →+* A) + (hCoefficient : ∀ b, g (normalCoefficient zeroDerivation b) = f b) + (hVariable : g (normalVariable zeroDerivation) = X) : + g = coordinateLift f X hX := + oreLift_unique zeroDerivation (coordinateAmbient f X hX) g + hCoefficient hVariable + +private theorem momentum_mul_coordinate_pow (X P : A) + (hPX : P * X = X * P + 1) (n : ℕ) : + P * X ^ n = X ^ n * P + n • X ^ (n - 1) := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ, ← mul_assoc, ih, add_mul, mul_assoc, hPX, mul_add] + by_cases hn : n = 0 + · subst n + simp + · have hpow : X ^ (n - 1) * X = X ^ n := by + rw [← pow_succ, Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hn)] + rw [nsmul_eq_mul, mul_assoc, hpow, ← nsmul_eq_mul] + simp only [Nat.add_sub_cancel, mul_one, mul_assoc, succ_nsmul] + abel + +/-- The coefficient and generator relations imply the full coordinate +derivation relation. No commutativity of either coefficient ring is used. -/ +theorem coordinateLift_derivation_relation (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) (z : CoordinateStage (B := B)) : + P * coordinateLift f X hX z = + coordinateLift f X hX z * P + + coordinateLift f X hX (coordinateDerivation z) := by + rcases normalForm_surjective zeroDerivation z with ⟨p, rfl⟩ + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [normalForm_add, (coordinateLift f X hX).map_add, + coordinateDerivation.map_add, (coordinateLift f X hX).map_add, + mul_add, add_mul, hp, hq] + abel + | monomial n b => + rw [coordinateDerivation_normalForm, Polynomial.derivative_monomial, + normalForm_monomial, map_mul, map_pow, + coordinateLift_coefficient, coordinateLift_variable, + normalForm_monomial, map_mul, map_pow, + coordinateLift_coefficient, coordinateLift_variable] + rw [← mul_assoc, hP, mul_assoc, momentum_mul_coordinate_pow X P hPX n] + simp only [add_mul, mul_add, mul_assoc] + congr 1 + rw [map_mul, map_natCast, nsmul_eq_mul] + simp only [mul_assoc] + +/-- The outer Ore ambient determined by commuting coefficient images and a +coordinate-momentum Weyl pair. -/ +def pairAmbient (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + OreAmbient (CoordinateStage (B := B)) A coordinateDerivation where + embed := coordinateLift f X hX + x := P + relation := coordinateLift_derivation_relation f X P hX hP hPX + +/-- The universal ring map from a coordinate-momentum pair stage. -/ +def pairLift (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + PairStage (B := B) →+* A := + oreLift coordinateDerivation (pairAmbient f X P hX hP hPX) + +@[simp] theorem pairLift_coefficient (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) + (b : B) : + pairLift f X P hX hP hPX (pairCoefficient b) = f b := by + change pairLift f X P hX hP hPX + (normalCoefficient coordinateDerivation + (normalCoefficient zeroDerivation b)) = f b + rw [pairLift, oreLift_coefficient] + change coordinateLift f X hX (normalCoefficient zeroDerivation b) = f b + exact coordinateLift_coefficient f X hX b + +@[simp] theorem pairLift_coordinate (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + pairLift f X P hX hP hPX pairCoordinate = X := by + change pairLift f X P hX hP hPX + (normalCoefficient coordinateDerivation + (normalVariable zeroDerivation)) = X + rw [pairLift, oreLift_coefficient] + change coordinateLift f X hX (normalVariable zeroDerivation) = X + exact coordinateLift_variable f X hX + +@[simp] theorem pairLift_momentum (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + pairLift f X P hX hP hPX pairMomentum = P := by + exact oreLift_variable coordinateDerivation (pairAmbient f X P hX hP hPX) + +/-- A ring map out of `PairStage` is determined by the old coefficients and +the two newly adjoined generators. -/ +theorem pairLift_unique (f : B →+* A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) + (g : PairStage (B := B) →+* A) + (hCoefficient : ∀ b, g (pairCoefficient b) = f b) + (hCoordinate : g pairCoordinate = X) + (hMomentum : g pairMomentum = P) : + g = pairLift f X P hX hP hPX := by + let inner : CoordinateStage (B := B) →+* A := + g.comp (normalCoefficient coordinateDerivation) + have hInner : inner = coordinateLift f X hX := by + apply coordinateLift_unique f X hX + · intro b + exact hCoefficient b + · exact hCoordinate + apply oreLift_unique coordinateDerivation (pairAmbient f X P hX hP hPX) + · intro z + exact DFunLike.congr_fun hInner z + · exact hMomentum + +section Scalars + +variable {k : Type*} [CommRing k] [Algebra k B] [Algebra k A] + +local instance : Algebra k (PairStage (B := B)) := + pairStageAlgebra (k := k) (B := B) + +/-- The pair lift as a scalar-preserving algebra map. -/ +def pairLiftAlgHom (f : B →ₐ[k] A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + PairStage (B := B) →ₐ[k] A where + toRingHom := pairLift f.toRingHom X P hX hP hPX + commutes' c := by + rw [pairStageAlgebra_algebraMap] + exact pairLift_coefficient f.toRingHom X P hX hP hPX (algebraMap k B c) + |>.trans (f.commutes c) + +@[simp] theorem pairLiftAlgHom_coefficient (f : B →ₐ[k] A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) + (b : B) : + pairLiftAlgHom f X P hX hP hPX (pairCoefficient b) = f b := by + change pairLift f.toRingHom X P hX hP hPX (pairCoefficient b) = f b + exact pairLift_coefficient f.toRingHom X P hX hP hPX b + +@[simp] theorem pairLiftAlgHom_coordinate (f : B →ₐ[k] A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + pairLiftAlgHom f X P hX hP hPX pairCoordinate = X := by + change pairLift f.toRingHom X P hX hP hPX pairCoordinate = X + exact pairLift_coordinate f.toRingHom X P hX hP hPX + +@[simp] theorem pairLiftAlgHom_momentum (f : B →ₐ[k] A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) : + pairLiftAlgHom f X P hX hP hPX pairMomentum = P := by + change pairLift f.toRingHom X P hX hP hPX pairMomentum = P + exact pairLift_momentum f.toRingHom X P hX hP hPX + +theorem pairLiftAlgHom_unique (f : B →ₐ[k] A) (X P : A) + (hX : ∀ b, X * f b = f b * X) + (hP : ∀ b, P * f b = f b * P) + (hPX : P * X = X * P + 1) + (g : PairStage (B := B) →ₐ[k] A) + (hCoefficient : ∀ b, g (pairCoefficient b) = f b) + (hCoordinate : g pairCoordinate = X) + (hMomentum : g pairMomentum = P) : + g = pairLiftAlgHom f X P hX hP hPX := by + apply AlgHom.ext + intro z + exact DFunLike.congr_fun + (pairLift_unique f.toRingHom X P hX hP hPX g.toRingHom + hCoefficient hCoordinate hMomentum) z + +end Scalars + + +end +end Stafford38.OrePairUniversal diff --git a/LeanPool/Stafford38/Stafford38/Ore/ScalarAlgebra.lean b/LeanPool/Stafford38/Stafford38/Ore/ScalarAlgebra.lean new file mode 100644 index 0000000000..c99cc56b14 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Ore/ScalarAlgebra.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Ore.CoordinateStage + +/-! +# Scalar algebra structure on an Ore extension + +If the coefficient ring is a `k`-algebra and the derivation kills `k`, then +the canonical image of `k` is central in the normal-form Ore ring. +-/ + +namespace Stafford38.OreScalarAlgebra + +open Polynomial +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity + +noncomputable section + +variable {k B : Type*} [CommRing k] [Ring B] [Algebra k B] + +/-- Scalars killed by the derivation remain central after adjoining the Ore +variable. -/ +theorem normalScalar_commutes (D : OreDivisionDerivation B) + (hD : ∀ c : k, D (algebraMap k B c) = 0) (c : k) (z : NormalOre D) : + normalCoefficient D (algebraMap k B c) * z = + z * normalCoefficient D (algebraMap k B c) := by + rcases normalForm_surjective D z with ⟨p, rfl⟩ + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [normalForm_add, mul_add, add_mul, hp, hq] + | monomial n b => + rw [normalForm_monomial] + let s : NormalOre D := normalCoefficient D (algebraMap k B c) + let a : NormalOre D := normalCoefficient D b + let x : NormalOre D := normalVariable D + have hsa : Commute s a := by + change normalCoefficient D (algebraMap k B c) * normalCoefficient D b = + normalCoefficient D b * normalCoefficient D (algebraMap k B c) + rw [← (normalCoefficient D).map_mul, ← (normalCoefficient D).map_mul, + Algebra.commutes c b] + have hsx : Commute s x := by + change normalCoefficient D (algebraMap k B c) * normalVariable D = + normalVariable D * normalCoefficient D (algebraMap k B c) + have h := normalVariable_mul_coefficient D (algebraMap k B c) + rw [hD c, map_zero, add_zero] at h + exact h.symm + exact (hsa.mul_right (hsx.pow_right n)).eq + +/-- The scalar algebra structure induced by the canonical coefficient map. -/ +def normalOreAlgebra (D : OreDivisionDerivation B) + (hD : ∀ c : k, D (algebraMap k B c) = 0) : Algebra k (NormalOre D) := + RingHom.toAlgebra' + ((normalCoefficient D).comp (algebraMap k B)) + (normalScalar_commutes D hD) + +theorem normalOreAlgebra_algebraMap (D : OreDivisionDerivation B) + (hD : ∀ c : k, D (algebraMap k B c) = 0) : + @algebraMap k (NormalOre D) _ _ (normalOreAlgebra D hD) = + (normalCoefficient D).comp (algebraMap k B) := rfl + + +end +end Stafford38.OreScalarAlgebra diff --git a/LeanPool/Stafford38/Stafford38/PaperInputs.lean b/LeanPool/Stafford38/Stafford38/PaperInputs.lean new file mode 100644 index 0000000000..0f716b9610 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/PaperInputs.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SpecializedNoncharacteristicEquality +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +import LeanPool.Stafford38.Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +import LeanPool.Stafford38.Stafford38.Weyl.FilteredScalarLifting +import LeanPool.Stafford38.Stafford38.FixedSourceAssembly + +/-! +# Typed assembly interfaces for the paper proof + +This module packages three application interfaces used by the canonical Weyl +construction. The first two include the characteristic-support and symbol +dictionaries; the third supplies a retained boundary place with a visible +divisor frame on each nonconstant component. + +`Stafford38.FoundationClosure` proves every field and imports this module on +the ordinary root dependency path. No field is installed as an axiom or +typeclass. The assembly theorems here remain conditional when considered in +isolation; their hypotheses are discharged by the unconditional development. +-/ + +namespace Stafford38.PaperInputs + +open Stafford38.CanonicalSupportVanishingReduction +open Stafford38.Characteristic +open Stafford38.CharacteristicTransposedFilteredModuleSupport +open Stafford38.EulerSurjectivity +open Stafford38.SpecializedNoncharacteristicEquality +open Stafford38.Geometry.CanonicalResidueExtensionAssembly +open Stafford38.Geometry.CanonicalNonconstantFiniteGradientProduction +open Stafford38.Geometry.CanonicalVisibleDivisorFrameProduction +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylEulerResidue +open Stafford38.WeylPBWMonicBridge +open Stafford38.Weyl.FilteredScalarLifting + +universe u + +/-- Exact Stafford-specific output of the noncharacteristic inverse-image +application. This is support avoidance, not the stronger filtered predecessor +to which it is converted by a separate trust-zero algebraic theorem. -/ +def CanonicalNoncharacteristicSupportAvoidance : Prop := + ∀ (k : Type u) [Field k] [CharZero k] [IsAlgClosed k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + Disjoint + (transposedOrderAssociatedGradedSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (PrimeSpectrum.zeroLocus + ({MvPolynomial.X (.inl (0 : Fin (n + 1)))} : + Set (SymbolRing k (n + 1)))) + +/-- Assembly interfaces whose fields are proved in `Stafford38.FoundationClosure`. -/ +structure Inputs : Prop where + noncharacteristicApplication : + CanonicalNoncharacteristicSupportAvoidance.{u} + residueExtensionSymbolControl : + CanonicalResidueExtensionSymbolControl.{u} + higherDimensionalVisibleDivisorFrameProduction : + HigherDimensionalCanonicalVisibleDivisorFrameProduction.{u} + +/-- Canonical support vanishes under the three explicit paper inputs. +This theorem is conditional and introduces no project axiom. -/ +theorem canonicalSupportVanishing_of_inputs (h : Inputs.{u}) : + Stafford38.UniversalAssembly.CanonicalSupportVanishing.{u} := by + let hunit : CanonicalStrictUnitCoordinatePreimage.{u} := by + intro k _ _ _ n N d hN hd + exact strictUnitCoordinatePreimage_of_transposedSupport_disjoint_axis + k n N d (h.noncharacteristicApplication k n N d hN hd) + exact canonicalSupportDescent + (algebraicallyClosedCanonicalSupportVanishing_of_residueExtension_rankSplit + hunit h.residueExtensionSymbolControl + (higherDimensionalCanonicalResidueExtensionConormalAxisProduction_of_nonconstantFiniteGradient + (higherDimensionalCanonicalResidueExtensionNonconstantFiniteGradientProduction_of_visibleDivisorFrame + h.higherDimensionalVisibleDivisorFrameProduction))) + +/-- The universal identity under the explicit paper inputs. -/ +theorem universalStatement_of_inputs (h : Inputs.{u}) : + Stafford38.UniversalStatement.{u} := + Stafford38.UniversalAssembly.universalStatement_of_canonicalSupportVanishing + (canonicalSupportVanishing_of_inputs h) + +/-- The stronger paper statement, with the exact Bernstein exponent. -/ +theorem universalFixedSourceStatement_of_inputs (h : Inputs.{u}) : + Stafford38.FixedSource.UniversalFixedSourceStatement.{u} := + Stafford38.FixedSource.universalFixedSourceStatement_of_canonicalSupportVanishing + (canonicalSupportVanishing_of_inputs h) + + +end Stafford38.PaperInputs diff --git a/LeanPool/Stafford38/Stafford38/PolynomialDifferentialOperators.lean b/LeanPool/Stafford38/Stafford38/PolynomialDifferentialOperators.lean new file mode 100644 index 0000000000..8bbb337497 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/PolynomialDifferentialOperators.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.DifferentialOperators +import LeanPool.Stafford38.Stafford38.Weyl.Universal +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence + +/-! +# The polynomial representation of the Weyl algebra + +The canonical coordinates act by multiplication and the canonical momenta by +formal partial differentiation. The target is the intrinsic algebra of +finite-order differential operators, so this construction does not assume an +identification of that algebra with the Weyl algebra. +-/ + +namespace Stafford38.PolynomialDifferentialOperators + +open Stafford +open Stafford38.DifferentialOperators +open Stafford38.WeylUniversal +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +variable (k : Type*) [Field k] (n : ℕ) + +abbrev PolynomialRing := MvPolynomial (Fin n) k + +def coordinateEnd (i : Fin n) : End (k := k) (R := PolynomialRing k n) := + multiplication (MvPolynomial.X i) + +def momentumEnd (i : Fin n) : End (k := k) (R := PolynomialRing k n) := + (MvPolynomial.pderiv i).toLinearMap + +theorem coordinateEnd_mem_order_zero (i : Fin n) : + coordinateEnd k n i ∈ order (k := k) (R := PolynomialRing k n) 0 := by + rw [mem_order_zero_iff_eq_multiplication] + ext f + simp [coordinateEnd, multiplication_apply] + +theorem momentumEnd_mem_order_one (i : Fin n) : + momentumEnd k n i ∈ order (k := k) (R := PolynomialRing k n) 1 := by + rw [show 1 = 0 + 1 by rfl, mem_order_succ_iff] + intro f + rw [mem_order_zero_iff_eq_multiplication] + apply LinearMap.ext + intro g + simp [commutator_apply, momentumEnd, multiplication_apply] + exact mul_comm _ _ + +def differentialGenerator : + (Fin n ⊕ Fin n) → algebra (k := k) (R := PolynomialRing k n) + | .inl i => ⟨coordinateEnd k n i, 0, coordinateEnd_mem_order_zero k n i⟩ + | .inr i => ⟨momentumEnd k n i, 1, momentumEnd_mem_order_one k n i⟩ + +theorem pderiv_comm (i j : Fin n) (f : PolynomialRing k n) : + MvPolynomial.pderiv i (MvPolynomial.pderiv j f) = + MvPolynomial.pderiv j (MvPolynomial.pderiv i f) := by + by_cases hij : i = j + · subst j + rfl + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => simp [hf, hg] + | mul_X f a hf => + classical + simp only [MvPolynomial.pderiv_mul, map_add] + rw [hf] + simp only [MvPolynomial.pderiv_X] + by_cases hai : a = i <;> by_cases haj : a = j <;> + simp [hai, haj, hij, Ne.symm hij] + +theorem differentialGenerator_commutator (i j : Fin n ⊕ Fin n) : + Stafford.commutator (differentialGenerator k n i) + (differentialGenerator k n j) = + algebraMap k (algebra (k := k) (R := PolynomialRing k n)) + (Matrix.J (Fin n) k i j) := by + apply Subtype.ext + apply LinearMap.ext + intro f + cases i with + | inl i => + cases j with + | inl j => simp [Stafford.commutator, differentialGenerator, coordinateEnd, + Module.End.mul_apply, Matrix.J, mul_comm, mul_assoc, mul_left_comm] + | inr j => + by_cases h : i = j + · subst j + simp [Stafford.commutator, differentialGenerator, coordinateEnd, momentumEnd, + Module.End.mul_apply, Matrix.J] + · simp [Stafford.commutator, differentialGenerator, coordinateEnd, momentumEnd, + Module.End.mul_apply, Matrix.J, h] + | inr i => + cases j with + | inl j => + by_cases h : i = j + · subst j + simp [Stafford.commutator, differentialGenerator, coordinateEnd, momentumEnd, + Module.End.mul_apply, Matrix.J] + · simp [Stafford.commutator, differentialGenerator, coordinateEnd, momentumEnd, + Module.End.mul_apply, Matrix.J, h] + | inr j => + simp [Stafford.commutator, differentialGenerator, momentumEnd, Module.End.mul_apply, + Matrix.J, pderiv_comm k n i j] + +/-- The polynomial action, valued in genuine finite-order differential operators. -/ +def polynomialDifferentialAction : + PresentedWeyl k n →ₐ[k] algebra (k := k) (R := PolynomialRing k n) := + freeWeylLift (Matrix.J (Fin n) k) (differentialGenerator k n) + (differentialGenerator_commutator k n) + +@[simp] theorem polynomialDifferentialAction_generator (i : Fin n ⊕ Fin n) : + polynomialDifferentialAction k n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = differentialGenerator k n i := + freeWeylLift_generator _ _ _ i + +theorem polynomialDifferentialAction_mem (d : PresentedWeyl k n) : + (polynomialDifferentialAction k n d : End (k := k) (R := PolynomialRing k n)) ∈ + algebra (k := k) (R := PolynomialRing k n) := + (polynomialDifferentialAction k n d).property + +end +end Stafford38.PolynomialDifferentialOperators diff --git a/LeanPool/Stafford38/Stafford38/PolynomialOperatorCommutators.lean b/LeanPool/Stafford38/Stafford38/PolynomialOperatorCommutators.lean new file mode 100644 index 0000000000..c85404b9f8 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/PolynomialOperatorCommutators.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.PolynomialDifferentialOperators + +/-! Coordinate commutators on the intrinsic polynomial endomorphism ring. -/ + +namespace Stafford38.PolynomialOperatorCommutators + +open Stafford38.DifferentialOperators + +noncomputable section + +variable (k : Type*) [Field k] (n : ℕ) + +abbrev PolynomialRing := MvPolynomial (Fin n) k +abbrev Operator := Module.End k (PolynomialRing k n) +abbrev OperatorEnd := Module.End k (Operator k n) + +def coordinateCommutator (i : Fin n) : OperatorEnd k n where + toFun P := commutator P (MvPolynomial.X i) + map_add' P Q := by + apply LinearMap.ext + intro f + simp [commutator_apply, sub_eq_add_neg, add_mul] + noncomm_ring + map_smul' c P := by + apply LinearMap.ext + intro f + simp [commutator_apply, smul_sub] + +@[simp] theorem coordinateCommutator_apply (i : Fin n) (P : Operator k n) : + coordinateCommutator k n i P = commutator P (MvPolynomial.X i) := rfl + +theorem coordinateCommutator_comm (i j : Fin n) : + coordinateCommutator k n i * coordinateCommutator k n j = + coordinateCommutator k n j * coordinateCommutator k n i := by + apply LinearMap.ext + intro P + apply LinearMap.ext + intro f + simp [coordinateCommutator, commutator_apply, Module.End.mul_apply, + mul_add, add_mul, sub_eq_add_neg, mul_assoc, mul_comm, mul_left_comm] + abel + +def iteratedCoordinateCommutator (l : List (Fin n)) : OperatorEnd k n := + l.foldr (fun i T => coordinateCommutator k n i * T) 1 + +@[simp] theorem iteratedCoordinateCommutator_nil : + iteratedCoordinateCommutator k n [] = 1 := rfl + +theorem iteratedCoordinateCommutator_cons (i : Fin n) (l : List (Fin n)) : + iteratedCoordinateCommutator k n (i :: l) = + coordinateCommutator k n i * iteratedCoordinateCommutator k n l := rfl + +theorem iteratedCoordinateCommutator_append (l₁ l₂ : List (Fin n)) : + iteratedCoordinateCommutator k n (l₁ ++ l₂) = + iteratedCoordinateCommutator k n l₁ * iteratedCoordinateCommutator k n l₂ := by + induction l₁ with + | nil => simp + | cons i l ih => + change coordinateCommutator k n i * iteratedCoordinateCommutator k n (l ++ l₂) = _ + rw [ih] + rfl + +theorem iteratedCoordinateCommutator_swap (i j : Fin n) (l : List (Fin n)) : + iteratedCoordinateCommutator k n (i :: j :: l) = + iteratedCoordinateCommutator k n (j :: i :: l) := by + rw [iteratedCoordinateCommutator_cons, iteratedCoordinateCommutator_cons, + iteratedCoordinateCommutator_cons, iteratedCoordinateCommutator_cons] + rw [← mul_assoc, ← mul_assoc, coordinateCommutator_comm k n i j, mul_assoc] + +theorem coordinateCommutator_order_lower {m : ℕ} (i : Fin n) + (P : Operator k n) (hP : P ∈ order (k := k) (R := PolynomialRing k n) (m + 1)) : + coordinateCommutator k n i P ∈ order (k := k) (R := PolynomialRing k n) m := + hP (MvPolynomial.X i) + +theorem coordinateCommutator_order_zero (i : Fin n) (P : Operator k n) + (hP : P ∈ order (k := k) (R := PolynomialRing k n) 0) : + coordinateCommutator k n i P = 0 := + hP (MvPolynomial.X i) + +/-- An iterated coordinate commutator lowers intrinsic order by its exact +list length. The statement avoids truncated subtraction: the input order is +written as the desired residual order plus the number of commutators. -/ +theorem iteratedCoordinateCommutator_order_lower (l : List (Fin n)) {m : ℕ} + (P : Operator k n) + (hP : P ∈ order (k := k) (R := PolynomialRing k n) (m + l.length)) : + iteratedCoordinateCommutator k n l P ∈ + order (k := k) (R := PolynomialRing k n) m := by + induction l generalizing m with + | nil => simpa using hP + | cons i l ih => + rw [iteratedCoordinateCommutator_cons, Module.End.mul_apply] + apply coordinateCommutator_order_lower k n i + apply ih (m := m + 1) + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hP + +/-- More commutators than the intrinsic order annihilate an operator. -/ +theorem iteratedCoordinateCommutator_eq_zero_of_length_gt {m : ℕ} + (l : List (Fin n)) (P : Operator k n) + (hP : P ∈ order (k := k) (R := PolynomialRing k n) m) + (hl : m < l.length) : + iteratedCoordinateCommutator k n l P = 0 := by + induction l generalizing m P with + | nil => simp at hl + | cons i l ih => + simp only [List.length_cons] at hl + rw [iteratedCoordinateCommutator_cons, Module.End.mul_apply] + by_cases htail : m < l.length + · rw [ih P hP htail] + exact map_zero _ + · have hlen : l.length = m := by omega + apply coordinateCommutator_order_zero k n i + apply iteratedCoordinateCommutator_order_lower (k := k) (n := n) l + simpa [hlen] using hP + +/-- Coordinate commutators depend only on the multiset of coordinates in the +iteration list. This is the order-independent interface needed to encode a +multiindex by any list containing the prescribed multiplicities. -/ +theorem iteratedCoordinateCommutator_eq_of_perm {l₁ l₂ : List (Fin n)} + (h : l₁.Perm l₂) : + iteratedCoordinateCommutator k n l₁ = + iteratedCoordinateCommutator k n l₂ := by + induction h with + | nil => rfl + | cons i h ih => + rw [iteratedCoordinateCommutator_cons, iteratedCoordinateCommutator_cons, ih] + | swap i j l => exact (iteratedCoordinateCommutator_swap k n i j l).symm + | trans _ _ ih₁ ih₂ => exact ih₁.trans ih₂ + +end +end Stafford38.PolynomialOperatorCommutators diff --git a/LeanPool/Stafford38/Stafford38/PolynomialOperatorTaylorProjection.lean b/LeanPool/Stafford38/Stafford38/PolynomialOperatorTaylorProjection.lean new file mode 100644 index 0000000000..d75293c35e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/PolynomialOperatorTaylorProjection.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.PolynomialOperatorCommutators +import LeanPool.Stafford38.AlgebraicAnalysis.LinearAlgebra.FiniteTaylorReconstruction + +/-! +# One-coordinate Taylor projection for polynomial operators + +This file constructs the finite Taylor projection using the actual polynomial +operator representation. Products are compositions and the powers of the +partial derivative stay on the right. +-/ + +namespace Stafford38.PolynomialOperatorTaylorProjection + +open scoped BigOperators +open Stafford38.PolynomialDifferentialOperators +open Stafford38.PolynomialOperatorCommutators + +noncomputable section + +variable (k : Type*) [Field k] [CharZero k] (n : ℕ) + +abbrev PolynomialRing := MvPolynomial (Fin n) k +abbrev Operator := Module.End k (PolynomialRing k n) +abbrev OperatorEnd := Module.End k (Operator k n) + +/-- The actual finite Taylor projection in coordinate `i`. -/ +def projection (i : Fin n) (m : ℕ) (P : Operator k n) : Operator k n := + ∑ j ∈ Finset.range (m + 1), + ((-1 : k) ^ j / (j.factorial : k)) • + ((coordinateCommutator k n i ^ j) P * momentumEnd k n i ^ j) + +private theorem coordinateCommutator_mul (i : Fin n) (P Q : Operator k n) : + coordinateCommutator k n i (P * Q) = + coordinateCommutator k n i P * Q + P * coordinateCommutator k n i Q := by + apply LinearMap.ext + intro f + simp [coordinateCommutator, Stafford38.DifferentialOperators.commutator_apply, + Module.End.mul_apply] + +@[simp] theorem coordinateCommutator_momentum (i : Fin n) : + coordinateCommutator k n i (momentumEnd k n i) = 1 := by + apply LinearMap.ext + intro f + simp [coordinateCommutator, Stafford38.DifferentialOperators.commutator_apply, + momentumEnd, Module.End.mul_apply] + +private theorem coordinateCommutator_momentum_pow (i : Fin n) : ∀ j : ℕ, + coordinateCommutator k n i (momentumEnd k n i ^ j) = + (j : k) • momentumEnd k n i ^ (j - 1) + | 0 => by + apply LinearMap.ext + intro f + simp [coordinateCommutator, Stafford38.DifferentialOperators.commutator_apply] + | j + 1 => by + rw [pow_succ, coordinateCommutator_mul, coordinateCommutator_momentum] + rw [coordinateCommutator_momentum_pow] + cases j with + | zero => simp + | succ j => simp [pow_succ, add_mul, smul_mul_assoc, add_smul] + +private theorem iterate_succ_apply (T : OperatorEnd k n) (j : ℕ) (P : Operator k n) : + (T ^ (j + 1)) P = T ((T ^ j) P) := by + rw [pow_succ'] + rfl + +/-- Applying the coordinate commutator to the Taylor projection kills all +adjacent terms; the last term vanishes by the stated nilpotence hypothesis. -/ +theorem coordinateCommutator_projection_eq_zero (i : Fin n) (m : ℕ) + (P : Operator k n) + (hnil : (coordinateCommutator k n i ^ (m + 1)) P = 0) : + coordinateCommutator k n i (projection k n i m P) = 0 := by + simp only [projection, map_sum] + have hterm (j : ℕ) : + coordinateCommutator k n i + (((-1 : k) ^ j / (j.factorial : k)) • + ((coordinateCommutator k n i ^ j) P * momentumEnd k n i ^ j)) = + ((-1 : k) ^ j / (j.factorial : k)) • + (((coordinateCommutator k n i ^ (j + 1)) P * momentumEnd k n i ^ j) + + ((j : k) • + ((coordinateCommutator k n i ^ j) P * + momentumEnd k n i ^ (j - 1)))) := by + rw [map_smul, coordinateCommutator_mul, + coordinateCommutator_momentum_pow, iterate_succ_apply] + simp only [smul_add] + rw [mul_smul_comm, smul_smul] + simp_rw [hterm] + simp only [smul_add, Finset.sum_add_distrib] + rw [Finset.sum_range_succ] + rw [hnil] + simp only [zero_mul, smul_zero, add_zero] + -- Shift the derivative-of-the-right-factor sum by one. Its coefficient is + -- the negative of the next term in the first sum. + rw [Finset.sum_range_succ'] + simp only [Nat.cast_zero, zero_smul, zero_add] + have hcancel (j : ℕ) : + ((-1 : k) ^ j / (j.factorial : k)) • + ((coordinateCommutator k n i ^ (j + 1)) P * momentumEnd k n i ^ j) + + ((-1 : k) ^ (j + 1) / ((j + 1).factorial : k)) • + ((j + 1 : k) • + ((coordinateCommutator k n i ^ (j + 1)) P * + momentumEnd k n i ^ j)) = 0 := by + have hj : ((j + 1 : ℕ) : k) ≠ 0 := by exact_mod_cast Nat.succ_ne_zero j + have hfac : ((j.factorial : ℕ) : k) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero j + have hc : + ((-1 : k) ^ j / (j.factorial : k)) + + ((-1 : k) ^ (j + 1) / ((j + 1).factorial : k)) * (j + 1 : k) = 0 := by + rw [Nat.factorial_succ, Nat.cast_mul, Nat.cast_succ] + field_simp [hfac, hj] + ring + rw [smul_smul, ← add_smul, hc, zero_smul] + -- `sum_range_succ` exposes exactly the paired adjacent coefficients. + simp only [smul_zero, add_zero] + rw [← Finset.sum_add_distrib] + apply Finset.sum_eq_zero + intro j hj + simpa [Nat.succ_sub_one] using hcancel j + +end +end Stafford38.PolynomialOperatorTaylorProjection + +namespace Stafford.AllDegreeSliceTaylor.Field + +/- Compatibility export for the application-independent Taylor projector. -/ +export AlgebraicAnalysis.FiniteTaylorReconstruction (projectorMapG reconstruction_all) + +end Stafford.AllDegreeSliceTaylor.Field + +namespace Stafford38.PolynomialOperatorTaylorProjection + +open Stafford38.PolynomialDifferentialOperators +open Stafford38.PolynomialOperatorCommutators +open Stafford.AllDegreeSliceTaylor.Field + +noncomputable section + +variable (k : Type*) [Field k] [CharZero k] (n : ℕ) + +private def rightMomentum (i : Fin n) : + Operator k n →ₗ[k] Operator k n := + LinearMap.mulRight k (momentumEnd k n i) + +private theorem rightMomentum_pow_apply (i : Fin n) (j : ℕ) (P : Operator k n) : + (rightMomentum k n i ^ j) P = P * momentumEnd k n i ^ j := by + induction j with + | zero => simp [rightMomentum] + | succ j ih => + rw [pow_succ', Module.End.mul_apply, ih] + simp [rightMomentum, pow_succ, mul_assoc] + +private theorem projectorMapG_apply_eq_projection (i : Fin n) (m : ℕ) + (P : Operator k n) : + projectorMapG m (rightMomentum k n i) (coordinateCommutator k n i) P = + projection k n i m P := by + unfold projectorMapG projection + rw [LinearMap.sum_apply] + apply Finset.sum_congr rfl + intro j hj + change ((-1 : k) ^ j / (j.factorial : k)) • + ((rightMomentum k n i ^ j * coordinateCommutator k n i ^ j) P) = _ + rw [Module.End.mul_apply, rightMomentum_pow_apply] + +/-- Finite Taylor reconstruction for the actual polynomial operator. Every +power of the partial derivative occurs as a right factor. -/ +theorem reconstruction (i : Fin n) (m : ℕ) (P : Operator k n) + (hnil : (coordinateCommutator k n i ^ (m + 1)) P = 0) : + P = ∑ a ∈ Finset.range (m + 1), + ((1 : k) / (a.factorial : k)) • + (projection k n i m ((coordinateCommutator k n i ^ a) P) * + momentumEnd k n i ^ a) := by + have h := reconstruction_all m (rightMomentum k n i) + (coordinateCommutator k n i) P hnil + refine h.trans ?_ + apply Finset.sum_congr rfl + intro a ha + congr 1 + rw [Module.End.mul_apply, Module.End.mul_apply, rightMomentum_pow_apply, + projectorMapG_apply_eq_projection] + +end +end Stafford38.PolynomialOperatorTaylorProjection diff --git a/LeanPool/Stafford38/Stafford38/Quotient/EulerSurjectivity.lean b/LeanPool/Stafford38/Stafford38/Quotient/EulerSurjectivity.lean new file mode 100644 index 0000000000..40e0124ca9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Quotient/EulerSurjectivity.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Euler-normality surjectivity on a right quotient + +This file isolates the quotient argument used in the Stafford proof. A right +ideal is a submodule of the regular right module, encoded as an +`Aᵐᵒᵖ`-submodule of `A`. +-/ + +namespace Stafford38.EulerSurjectivity + +variable {A : Type*} [Ring A] + +/-- A right ideal, represented as a submodule of the regular right module. -/ +abbrev RightIdeal (A : Type*) [Ring A] := Submodule Aᵐᵒᵖ A + +/-- The additive quotient by a right ideal, with its induced right action. -/ +abbrev RightQuotient (I : RightIdeal A) := A ⧸ I + +/-- The quotient class of a ring element. -/ +def qmk (I : RightIdeal A) (a : A) : RightQuotient I := + Submodule.Quotient.mk a + +/-- Right multiplication on the quotient. -/ +def rightMul (I : RightIdeal A) (a : A) (q : RightQuotient I) : + RightQuotient I := + MulOpposite.op a • q + +lemma qmk_right_mul (I : RightIdeal A) (a b : A) : + qmk I (a * b) = rightMul I b (qmk I a) := by + exact Submodule.Quotient.mk_smul I (MulOpposite.op b) a + +/-- Elements whose quotient classes have representatives in `R`. -/ +def ReducesTo (I : RightIdeal A) (R : Subring A) (a : A) : Prop := + ∃ r : R, qmk I a = qmk I (r : A) + +/-- Right multipliers preserving the classes represented by `R`. -/ +def preservers (I : RightIdeal A) (R : Subring A) : Subring A where + carrier := {a | ∀ r : R, ReducesTo I R ((r : A) * a)} + zero_mem' := by + intro r + exact ⟨0, by simp [ReducesTo, qmk]⟩ + one_mem' := by + intro r + exact ⟨r, by simp [ReducesTo]⟩ + add_mem' := by + intro a b ha hb r + obtain ⟨s, hs⟩ := ha r + obtain ⟨t, ht⟩ := hb r + refine ⟨s + t, ?_⟩ + simpa [ReducesTo, mul_add, qmk, Submodule.Quotient.mk_add] using + congrArg₂ (· + ·) hs ht + neg_mem' := by + intro a ha r + obtain ⟨s, hs⟩ := ha r + refine ⟨-s, ?_⟩ + simpa [ReducesTo, qmk] using congrArg Neg.neg hs + mul_mem' := by + intro a b ha hb r + obtain ⟨s, hs⟩ := ha r + obtain ⟨t, ht⟩ := hb s + refine ⟨t, ?_⟩ + have hright := congrArg (rightMul I b) hs + rw [← qmk_right_mul, ← qmk_right_mul] at hright + simpa [mul_assoc] using hright.trans ht + +lemma subring_le_preservers (I : RightIdeal A) (R : Subring A) : + R ≤ preservers I R := by + intro a ha r + exact ⟨r * ⟨a, ha⟩, rfl⟩ + +/-- +The quotient form of the positive Euler argument. + +The relation `1 + U*x ∈ I`, normality `x*R ⊆ R*x`, the Euler element +`E = x*p ∈ R`, and generation of `A` by `R` and `p` imply that right +multiplication by `x` is onto `A/I`. +-/ +theorem rightMul_surjective_of_euler_normal + (I : RightIdeal A) (R : Subring A) (x p : A) + (hnormal : ∀ r : R, ∃ s : R, x * (r : A) = (s : A) * x) + (hE : x * p ∈ R) + (hresidue : ∃ U : R, 1 + (U : A) * x ∈ I) + (hgenerate : Subring.closure ((R : Set A) ∪ {p}) = ⊤) : + Function.Surjective (rightMul I x) := by + obtain ⟨U, hU⟩ := hresidue + + have hp : p ∈ preservers I R := by + intro r + obtain ⟨s, hs⟩ := hnormal r + refine ⟨-(U * s * ⟨x * p, hE⟩), ?_⟩ + apply (Submodule.Quotient.eq I).2 + have hmem := I.smul_mem (MulOpposite.op ((r : A) * p)) hU + change (1 + (U : A) * x) * ((r : A) * p) ∈ I at hmem + convert hmem using 1 + all_goals simp only [Subring.coe_neg, Subring.coe_mul] + calc + (r : A) * p - -((U : A) * (s : A) * (x * p)) = + (r : A) * p + (U : A) * ((s : A) * x) * p := by noncomm_ring + _ = (r : A) * p + (U : A) * (x * (r : A)) * p := by rw [hs] + _ = (1 + (U : A) * x) * ((r : A) * p) := by noncomm_ring + + have hall : preservers I R = ⊤ := by + apply top_unique + rw [← hgenerate] + apply Subring.closure_le.2 + intro a ha + rcases ha with ha | rfl + · exact subring_le_preservers I R ha + · simpa using hp + + intro q + obtain ⟨a, rfl⟩ := Submodule.Quotient.mk_surjective I q + have ha : a ∈ preservers I R := by + rw [hall] + trivial + obtain ⟨r, hr⟩ := ha (1 : R) + have har : qmk I a = qmk I (r : A) := by simpa using hr + obtain ⟨s, hs⟩ := hnormal r + refine ⟨qmk I (-((U : A) * (s : A))), ?_⟩ + change rightMul I x (qmk I (-((U : A) * (s : A)))) = qmk I a + rw [har, ← qmk_right_mul] + apply (Submodule.Quotient.eq I).2 + have hmem := I.smul_mem (MulOpposite.op (r : A)) hU + change (1 + (U : A) * x) * (r : A) ∈ I at hmem + have hmemneg := I.neg_mem hmem + change -((1 + (U : A) * x) * (r : A)) ∈ I at hmemneg + convert hmemneg using 1 + calc + (-((U : A) * (s : A))) * x - (r : A) = + -((r : A) + (U : A) * ((s : A) * x)) := by noncomm_ring + _ = -((r : A) + (U : A) * (x * (r : A))) := by rw [hs] + _ = -((1 + (U : A) * x) * (r : A)) := by noncomm_ring + + +end Stafford38.EulerSurjectivity diff --git a/LeanPool/Stafford38/Stafford38/Statement.lean b/LeanPool/Stafford38/Stafford38/Statement.lean new file mode 100644 index 0000000000..17ee2b5a0e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Statement.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.proofs.stafford38_reduction +import LeanPool.Stafford38.proofs.weyl_symplectic + +/-! +# The universal Stafford 3.8 target + +This file owns the exact theorem statement that the end-to-end formalization +must eventually prove. It intentionally declares no theorem with an unproved +hypothesis and introduces no project axiom. +-/ + +namespace Stafford38 + +/-- The presented `n`th Weyl algebra with its standard symplectic form. -/ +abbrev WeylAlg (k : Type*) [Field k] (n : ℕ) := + Stafford.FreeWeyl k (Fin n ⊕ Fin n) (Matrix.J (Fin n) k) + +/-- Exact proposition required for the publication theorem. -/ +def UniversalStatement : Prop := + ∀ (k : Type*) [Field k] [CharZero k] (n : ℕ) (d : WeylAlg k n), + d ≠ 0 → ∃ F R S : WeylAlg k n, (1 : WeylAlg k n) = d * R + F * d * S + +end Stafford38 diff --git a/LeanPool/Stafford38/Stafford38/UniversalAssembly.lean b/LeanPool/Stafford38/Stafford38/UniversalAssembly.lean new file mode 100644 index 0000000000..5ddc021639 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/UniversalAssembly.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Statement +import LeanPool.Stafford38.Stafford38.Characteristic.CanonicalCertificate +import LeanPool.Stafford38.Stafford38.Weyl.MonicNormalization +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge + +/-! +# Final assembly from the canonical support theorem + +This file discharges the scalar case, normalized symplectic-chart transport, +and fixed-source certificate transport in the exact universal statement. Its +single remaining hypothesis is the concrete support-vanishing theorem for the +literal canonical right ideal attached to a normalized PBW-monic operator. +-/ + +namespace Stafford38.UniversalAssembly + +open Stafford38 +open Stafford38.CharacteristicCanonicalCertificate +open Stafford38.CharacteristicInitialIdeal +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylMonicNormalization +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylSymplectic + +noncomputable section + +universe u + +/-- The one concrete theorem still needed by the final algebraic assembly. -/ +def CanonicalSupportVanishing : Prop := + ∀ (k : Type u) [Field k] [CharZero k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + 0 < N → IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d → + orderCharacteristicSupport k + (canonicalRightIdeal (presentedCoordinate k n) d N) = ∅ + +private theorem rankZero_certificate + (k : Type u) [Field k] (d : PresentedWeyl k 0) (hd : d ≠ 0) : + ∃ F R S : PresentedWeyl k 0, + (1 : PresentedWeyl k 0) = d * R + F * d * S := by + let e := presentedIteratedEquiv k 0 + let c : k := e d + have hc : c ≠ 0 := by + intro hczero + change e d = 0 at hczero + apply hd + calc + d = e.symm (e d) := (e.symm_apply_apply d).symm + _ = e.symm 0 := congrArg e.symm hczero + _ = 0 := map_zero e.symm + refine ⟨0, e.symm (c⁻¹ : k), 0, ?_⟩ + have hmul : c * c⁻¹ = (1 : k) := mul_inv_cancel₀ hc + have h : d * e.symm (c⁻¹ : k) = 1 := by + calc d * e.symm (c⁻¹ : k) + = e.symm c * e.symm (c⁻¹ : k) := by + congr 1 + exact (e.symm_apply_apply d).symm + _ = e.symm (c * c⁻¹) := (map_mul e.symm _ _).symm + _ = e.symm 1 := congrArg e.symm hmul + _ = 1 := map_one e.symm + simpa using h.symm + +/-- Once canonical support vanishing is proved, the exact theorem exported by +`Stafford38.Statement` follows with no further mathematical hypothesis. -/ +theorem universalStatement_of_canonicalSupportVanishing + (hvanish : CanonicalSupportVanishing.{u}) : + Stafford38.UniversalStatement.{u} := by + intro k _ _ n d hd + cases n with + | zero => + exact rankZero_certificate k d hd + | succ n => + rcases scalar_or_normalized_symplectic_image k (Nat.succ_pos n) hd with + hscalar | hchart + · rcases hscalar with ⟨c, hc, rfl⟩ + refine ⟨0, algebraMap k (PresentedWeyl k (n + 1)) c⁻¹, 0, ?_⟩ + simp only [zero_mul, zero_add] + rw [← map_mul] + rw [mul_inv_cancel₀ hc, map_one] + simp + · rcases hchart with ⟨N, hN, M, Ninv, c, hM, hNinv, hMN, hNM, + hc, hpiece, haxis⟩ + let e := standardSymplecticAlgEquivOfInverse + k M Ninv hM hNinv hMN hNM + let d' : PresentedWeyl k (n + 1) := + normalizedSymplecticImage k M hM c d + have hd' : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d' := by + refine ⟨hpiece, ?_⟩ + rw [← coeff_principal_pure_eq_normalForm k] + rw [← coeff_axisPolynomial k] + exact haxis + have hsupp := hvanish k n N d' hN hd' + rcases exists_fixedSource_certificate_of_orderCharacteristicSupport_eq_empty + k n N d' hsupp with ⟨R, S, hcert⟩ + let a : PresentedWeyl k (n + 1) := + algebraMap k (PresentedWeyl k (n + 1)) c⁻¹ + have hd'eq : d' = a * e d := by + simp [d', a, e, normalizedSymplecticImage, Algebra.smul_def, + standardSymplecticAlgEquivOfInverse] <;> rfl + have ha_comm : ∀ z : PresentedWeyl k (n + 1), a * z = z * a := by + intro z + exact Algebra.commutes c⁻¹ z + have hchartCert : + (1 : PresentedWeyl k (n + 1)) = + e d * (a * R) + + (presentedCoordinate k n) ^ N * e d * (a * S) := by + rw [hcert, hd'eq] + rw [ha_comm (e d)] + simp only [mul_assoc] + refine ⟨e.symm ((presentedCoordinate k n) ^ N), + e.symm (a * R), e.symm (a * S), ?_⟩ + have htransport := congrArg e.symm hchartCert + simpa using htransport + + +end + +end Stafford38.UniversalAssembly diff --git a/LeanPool/Stafford38/Stafford38/Weyl/AssociatedGraded.lean b/LeanPool/Stafford38/Stafford38/Weyl/AssociatedGraded.lean new file mode 100644 index 0000000000..a59b04adbc --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/AssociatedGraded.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.LeadingSymbol +import Mathlib.LinearAlgebra.Isomorphisms + +/-! +# Associated graded pieces of the PBW filtrations + +The strict lower piece in degree `N` is the kernel of degree-`N` principal +component projection. Restricting that projection to the filtered piece is +surjective onto the weighted-homogeneous symbol submodule, so each filtered +quotient is canonically linearly equivalent to its symbol component. The +external graded multiplication is a downstream construction. +-/ + +namespace Stafford38.WeylAssociatedGraded + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBW +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- The part of a filtration piece strictly below degree `N`; degree zero has +zero lower piece. -/ +def presentedStrictLowerPiece {n : ℕ} (w : PhaseVar n → ℕ) : + (N : ℕ) → Submodule k (PresentedWeyl k n) + | 0 => ⊥ + | N + 1 => presentedWeightPiece k w N + +theorem presentedStrictLowerPiece_le {n N : ℕ} + (w : PhaseVar n → ℕ) : + presentedStrictLowerPiece k w N ≤ presentedWeightPiece k w N := by + cases N with + | zero => exact bot_le + | succ N => exact presentedWeightPiece_mono k w (Nat.le_succ N) + +theorem presentedPrincipalComponent_eq_zero_iff_mem_strictLower + {n N : ℕ} (w : PhaseVar n → ℕ) (z : PresentedWeyl k n) + (hz : z ∈ presentedWeightPiece k w N) : + presentedPrincipalComponent k w N z = 0 ↔ + z ∈ presentedStrictLowerPiece k w N := by + constructor + · intro hp + cases N with + | zero => + rw [presentedStrictLowerPiece, Submodule.mem_bot] + apply (presentedNormalFormLinearEquiv k n).injective + ext m + have hle := (mem_presentedWeightPiece k w 0 z).mp hz + have hpc := congrArg (MvPolynomial.coeff m) hp + rw [coeff_presentedPrincipalComponent, + MvPolynomial.coeff_zero] at hpc + by_cases hc : + MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n z) = 0 + · rw [hc] + simp + · have hw : monomialWeight w m = 0 := Nat.eq_zero_of_le_zero (hle m hc) + simpa [hw] using hpc + | succ N => + rw [presentedStrictLowerPiece, mem_presentedWeightPiece] + intro m hm + have hle := (mem_presentedWeightPiece k w (N + 1) z).mp hz m hm + have hpc := congrArg (MvPolynomial.coeff m) hp + rw [coeff_presentedPrincipalComponent, + MvPolynomial.coeff_zero] at hpc + by_contra hnot + have heq : monomialWeight w m = N + 1 := by omega + simp [heq, hm] at hpc + · intro hlower + cases N with + | zero => + rw [presentedStrictLowerPiece, Submodule.mem_bot] at hlower + subst z + exact map_zero _ + | succ N => + exact presentedPrincipalComponent_eq_zero_of_mem_of_lt k w z + hlower (Nat.lt_succ_self N) + +/-- The principal component restricted to the degree-`N` filtration piece, +with codomain narrowed to the degree-`N` homogeneous symbol submodule. -/ +def principalComponentOnPiece {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + presentedWeightPiece k w N →ₗ[k] + MvPolynomial.weightedHomogeneousSubmodule k w N where + toFun z := ⟨presentedPrincipalComponent k w N z, + MvPolynomial.weightedHomogeneousComponent_mem w + (presentedNormalFormLinearEquiv k n z) N⟩ + map_add' x y := by + ext + simp [presentedPrincipalComponent] + map_smul' c x := by + ext + simp [presentedPrincipalComponent] + +theorem mem_ker_principalComponentOnPiece_iff {n N : ℕ} + (w : PhaseVar n → ℕ) (z : presentedWeightPiece k w N) : + z ∈ LinearMap.ker (principalComponentOnPiece k w N) ↔ + (z : PresentedWeyl k n) ∈ presentedStrictLowerPiece k w N := by + rw [LinearMap.mem_ker] + constructor + · intro h + have hp : presentedPrincipalComponent k w N z = 0 := + congrArg (fun f : MvPolynomial.weightedHomogeneousSubmodule k w N => + (f : SymbolRing k n)) h + exact (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k w z z.property).mp hp + · intro hlower + apply Subtype.ext + exact (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k w z z.property).mpr hlower + +/-- The kernel of principal-component projection is exactly the strict lower +filtration piece, viewed inside the degree-`N` piece. -/ +theorem ker_principalComponentOnPiece_eq {n N : ℕ} + (w : PhaseVar n → ℕ) : + LinearMap.ker (principalComponentOnPiece k w N) = + (presentedStrictLowerPiece k w N).comap + (presentedWeightPiece k w N).subtype := by + ext z + exact mem_ker_principalComponentOnPiece_iff k w z + +theorem principalComponentOnPiece_surjective {n N : ℕ} + (w : PhaseVar n → ℕ) : + Function.Surjective (principalComponentOnPiece k w N) := by + intro f + let z : PresentedWeyl k n := + (presentedNormalFormLinearEquiv k n).symm (f : SymbolRing k n) + have hz : z ∈ presentedWeightPiece k w N := by + rw [mem_presentedWeightPiece] + intro m hm + have hnormal : presentedNormalFormLinearEquiv k n z = (f : SymbolRing k n) := by + exact (presentedNormalFormLinearEquiv k n).apply_symm_apply f + rw [hnormal] at hm + have hw := f.property hm + rw [finsupp_weight_eq_monomialWeight] at hw + exact le_of_eq hw + refine ⟨⟨z, hz⟩, ?_⟩ + apply Subtype.ext + change presentedPrincipalComponent k w N z = (f : SymbolRing k n) + rw [presentedPrincipalComponent, LinearMap.comp_apply] + change MvPolynomial.weightedHomogeneousComponent w N + (presentedNormalFormLinearEquiv k n z) = (f : SymbolRing k n) + rw [show presentedNormalFormLinearEquiv k n z = (f : SymbolRing k n) from + (presentedNormalFormLinearEquiv k n).apply_symm_apply f] + exact f.property.weightedHomogeneousComponent_same + +local instance (priority := 10000) presentedWeightPieceHasQuotient {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) : + HasQuotient (presentedWeightPiece k w N) + (Submodule k (presentedWeightPiece k w N)) := + @Submodule.hasQuotient k (presentedWeightPiece k w N) _ + (presentedWeightPiece k w N).addCommGroup + (presentedWeightPiece k w N).module + +/-- The degree-`N` associated graded piece, presented canonically as the +quotient by the kernel of principal-component projection. The preceding +kernel theorem identifies this kernel with the strict lower filtration. -/ +abbrev presentedAssociatedGradedPiece {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) := + (presentedWeightPiece k w N) ⧸ + LinearMap.ker (principalComponentOnPiece k w N) + +local instance (priority := 10000) presentedAssociatedGradedPieceAddCommGroup + {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + AddCommGroup (presentedAssociatedGradedPiece k w N) := + @Submodule.Quotient.addCommGroup k (presentedWeightPiece k w N) _ + (presentedWeightPiece k w N).addCommGroup + (presentedWeightPiece k w N).module + (LinearMap.ker (principalComponentOnPiece k w N)) + +local instance (priority := 10000) presentedAssociatedGradedPieceModule + {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + Module k (presentedAssociatedGradedPiece k w N) := + @Submodule.Quotient.module k (presentedWeightPiece k w N) _ + (presentedWeightPiece k w N).addCommGroup + (presentedWeightPiece k w N).module + (LinearMap.ker (principalComponentOnPiece k w N)) + +/-- Every associated graded piece is linearly equivalent to the corresponding +weighted-homogeneous symbol submodule. -/ +def presentedAssociatedGradedPieceEquiv {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) : + presentedAssociatedGradedPiece k w N ≃ₗ[k] + MvPolynomial.weightedHomogeneousSubmodule k w N := + @LinearMap.quotKerEquivOfSurjective k + (presentedWeightPiece k w N) + (MvPolynomial.weightedHomogeneousSubmodule k w N) _ + (presentedWeightPiece k w N).addCommGroup + (MvPolynomial.weightedHomogeneousSubmodule k w N).addCommGroup + (presentedWeightPiece k w N).module + (MvPolynomial.weightedHomogeneousSubmodule k w N).module + (principalComponentOnPiece k w N) + (principalComponentOnPiece_surjective k w) + +theorem presentedAssociatedGradedPieceEquiv_mk {n N : ℕ} + (w : PhaseVar n → ℕ) (z : presentedWeightPiece k w N) : + presentedAssociatedGradedPieceEquiv k w N (Submodule.Quotient.mk z) = + principalComponentOnPiece k w N z := by + rfl + + +end + +end Stafford38.WeylAssociatedGraded diff --git a/LeanPool/Stafford38/Stafford38/Weyl/CommutatorSymbol.lean b/LeanPool/Stafford38/Stafford38/Weyl/CommutatorSymbol.lean new file mode 100644 index 0000000000..473f49ace2 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/CommutatorSymbol.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.GradedAlgebra +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial + +/-! +# Coordinate commutators and order symbols + +This file proves the newest-coordinate generator case of the filtered +commutator--Poisson correspondence. It uses the exact PBW block normal form; +no characteristic-ideal, radical, or Gabber statement is assumed. +-/ + +namespace Stafford38.WeylCommutatorSymbol + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBW +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Commutation with the newest coordinate differentiates the momentum power +in an exact ordered PBW block, with the sign dictated by `[x,p] = -1`. -/ +theorem presentedCoordinate_commutator_coefficientOrdered + (n a p : ℕ) (z : PresentedWeyl k n) : + Stafford.commutator (presentedCoordinate k n) + (presentedCoefficientOrdered k n a p z) = + -((p : k) • presentedCoefficientOrdered k n a (p - 1) z) := by + let X := presentedCoordinate k n + let P := presentedMomentum k n + let Z := previousWeylEmbedding k n z + have hXZ : X * Z = Z * X := + presentedCoordinate_commutes_previous k n z + have hPX : P * X = X * P + 1 := presentedMomentum_mul_coordinate k n + have hpowSucc : ∀ r : ℕ, + X * P ^ (r + 1) - P ^ (r + 1) * X = -((r + 1) • P ^ r) := by + intro r + let Xop : (PresentedWeyl k (n + 1))ᵐᵒᵖ := MulOpposite.op X + let Pop : (PresentedWeyl k (n + 1))ᵐᵒᵖ := MulOpposite.op P + have hop : Xop * Pop - Pop * Xop = 1 := by + have hopEq := congrArg MulOpposite.op hPX + change MulOpposite.op X * MulOpposite.op P - + MulOpposite.op P * MulOpposite.op X = 1 + rw [show MulOpposite.op X * MulOpposite.op P = + MulOpposite.op P * MulOpposite.op X + 1 by simpa using hopEq] + abel + have ht := AlgebraicAnalysis.OreDivision.OreAmbient.commutator_pow_succ + Xop Pop hop r + have hu := congrArg MulOpposite.unop ht + change P ^ (r + 1) * X - X * P ^ (r + 1) = (r + 1) • P ^ r at hu + rw [← hu] + abel + have hpow : ∀ q : ℕ, + X * P ^ q - P ^ q * X = -((q : k) • P ^ (q - 1)) := by + intro q + cases q with + | zero => simp + | succ r => + rw [Nat.cast_smul_eq_nsmul k] + exact hpowSucc r + rw [presentedCoefficientOrdered] + change X * (Z * X ^ a * P ^ p) - (Z * X ^ a * P ^ p) * X = _ + let Q := Z * X ^ a + have hXpow : X * X ^ a = X ^ a * X := (Commute.refl X).pow_right a + have hQ : Stafford.commutator X Q = 0 := by + change X * (Z * X ^ a) - (Z * X ^ a) * X = 0 + rw [show X * (Z * X ^ a) = (Z * X ^ a) * X by + calc + X * (Z * X ^ a) = (X * Z) * X ^ a := by rw [mul_assoc] + _ = (Z * X) * X ^ a := by rw [hXZ] + _ = Z * (X * X ^ a) := by rw [mul_assoc] + _ = Z * (X ^ a * X) := by rw [hXpow] + _ = (Z * X ^ a) * X := by rw [mul_assoc]] + exact sub_self _ + change Stafford.commutator X (Q * P ^ p) = _ + calc + Stafford.commutator X (Q * P ^ p) = + Stafford.commutator X Q * P ^ p + + Q * Stafford.commutator X (P ^ p) := by + simp only [Stafford.commutator, + AlgebraicAnalysis.ringCommutator, sub_mul, mul_sub, mul_assoc] + abel + _ = Q * (X * P ^ p - P ^ p * X) := by + have hQ' : X * Q - Q * X = 0 := by exact hQ + change (X * Q - Q * X) * P ^ p + + Q * (X * P ^ p - P ^ p * X) = _ + rw [hQ', zero_mul, zero_add] + _ = Q * -((p : k) • P ^ (p - 1)) := by rw [hpow] + _ = -((p : k) • (Q * P ^ (p - 1))) := by + calc + Q * -((p : k) • P ^ (p - 1)) = + -(Q * ((p : k) • P ^ (p - 1))) := by + simpa only using (mul_neg Q ((p : k) • P ^ (p - 1))) + _ = -((p : k) • (Q * P ^ (p - 1))) := + congrArg Neg.neg + (Algebra.mul_smul_comm (p : k) Q (P ^ (p - 1))) + +@[simp] theorem poissonBracket_newestCoordinate + (n : ℕ) (f : SymbolRing k (n + 1)) : + poissonBracket (MvPolynomial.X (.inl (0 : Fin (n + 1)))) f = + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) f := by + simp only [poissonBracket, MvPolynomial.pderiv_X, mul_zero, sub_zero] + rw [Finset.sum_eq_single (0 : Fin (n + 1))] + · simp + · intro i _ hi + simp [Pi.single_apply, hi] + · simp + +theorem pderiv_rename_oldIndex_newestMomentum + (n : ℕ) (f : SymbolRing k n) : + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (MvPolynomial.rename oldIndex f) = 0 := by + classical + induction f using MvPolynomial.induction_on' with + | monomial m c => + rw [MvPolynomial.rename_monomial, MvPolynomial.pderiv_monomial] + have hz : (m.mapDomain oldIndex) (.inr (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨i, hi⟩ + cases i <;> simp [oldIndex, Fin.succ_ne_zero] at hi + simp [hz] + | add f g hf hg => simp [map_add, hf, hg] + +theorem extendPhaseExponent_sub_newestMomentum + (n a p : ℕ) : + extendPhaseExponent n a p 0 - + Finsupp.single (.inr (0 : Fin (n + 1))) 1 = + extendPhaseExponent n a (p - 1) 0 := by + classical + ext i + rcases i with i | i + · by_cases hi : i = 0 + · subst i + simp [extendPhaseExponent, oldIndex] + · simp [extendPhaseExponent, oldIndex, hi] + · by_cases hi : i = 0 + · subst i + simp [extendPhaseExponent, oldIndex] + · simp [extendPhaseExponent, oldIndex, hi] + +/-- Generator/ordered-block case of the order-symbol commutator formula. +The exact degree is `N+p-1`; positivity of `p` prevents truncated subtraction. +The sign records the repository convention `[x,p] = -1`. -/ +theorem principalComponent_coordinate_commutator_eq_neg_poisson + (n N a p : ℕ) (z : PresentedWeyl k n) (hp : 0 < p) : + presentedPrincipalComponent k (@orderWeight (n + 1)) (N + p - 1) + (Stafford.commutator (presentedCoordinate k n) + (presentedCoefficientOrdered k n a p z)) = + -poissonBracket (MvPolynomial.X (.inl (0 : Fin (n + 1)))) + (presentedPrincipalComponent k (@orderWeight (n + 1)) (N + p) + (presentedCoefficientOrdered k n a p z)) := by + rw [presentedCoordinate_commutator_coefficientOrdered] + simp only [map_neg, map_smul] + rw [show N + p - 1 = N + (p - 1) by omega, + presentedPrincipalComponent_coefficientOrdered_order, + presentedPrincipalComponent_coefficientOrdered_order, + poissonBracket_newestCoordinate, + MvPolynomial.pderiv_mul, + MvPolynomial.pderiv_monomial, + pderiv_rename_oldIndex_newestMomentum, + mul_zero, add_zero, + extendPhaseExponent_sub_newestMomentum n a p] + have hexp : (extendPhaseExponent n a p 0) + (.inr (0 : Fin (n + 1))) = p := by + simp [extendPhaseExponent, oldIndex] + rw [hexp] + congr 1 + rw [← Algebra.smul_mul_assoc, MvPolynomial.smul_monomial] + simp + + +end + +end Stafford38.WeylCommutatorSymbol diff --git a/LeanPool/Stafford38/Stafford38/Weyl/CoordinateCommutatorSymbol.lean b/LeanPool/Stafford38/Stafford38/Weyl/CoordinateCommutatorSymbol.lean new file mode 100644 index 0000000000..bf16e36b1d --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/CoordinateCommutatorSymbol.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.CommutatorSymbol + +/-! +# Coordinate commutators on arbitrary PBW sums + +This file extends the ordered-block commutator--symbol formula to arbitrary +presented Weyl elements. The proof packages both sides as linear maps and +checks equality on the full PBW basis. +-/ + +namespace Stafford38.WeylCoordinateCommutatorSymbol + +open Stafford38.Characteristic +open Stafford38.WeylCommutatorSymbol +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Commutation with the newest coordinate, followed by extraction of one +order-homogeneous component, as a linear map. -/ +def coordinateCommutatorPrincipalLinear (n T : ℕ) : + PresentedWeyl k (n + 1) →ₗ[k] SymbolRing k (n + 1) where + toFun w := + presentedPrincipalComponent k (@orderWeight (n + 1)) T + (Stafford.commutator (presentedCoordinate k n) w) + map_add' a b := by + change presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) (a + b)) = + presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) a) + + presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) b) + rw [show Stafford.commutator (presentedCoordinate k n) (a + b) = + Stafford.commutator (presentedCoordinate k n) a + + Stafford.commutator (presentedCoordinate k n) b by + simp only [Stafford.commutator, AlgebraicAnalysis.ringCommutator, + mul_add, add_mul] + abel] + exact LinearMap.map_add _ _ _ + map_smul' c a := by + change presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) (c • a)) = + c • presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) a) + rw [show Stafford.commutator (presentedCoordinate k n) (c • a) = + c • Stafford.commutator (presentedCoordinate k n) a by + simp only [Stafford.commutator, AlgebraicAnalysis.ringCommutator, + Algebra.mul_smul_comm, + Algebra.smul_mul_assoc, smul_sub]] + exact LinearMap.map_smul _ _ _ + +/-- The negative Poisson derivative of the next order-homogeneous component, +as a linear map. -/ +def coordinatePoissonPrincipalLinear (n T : ℕ) : + PresentedWeyl k (n + 1) →ₗ[k] SymbolRing k (n + 1) := + (-((MvPolynomial.pderiv (R := k) + (Sum.inr (0 : Fin (n + 1)) : PhaseVar (n + 1))).toLinearMap)).comp + (presentedPrincipalComponent k (@orderWeight (n + 1)) (T + 1)) + +/-- A PBW basis vector in `n+1` pairs is an ordered newest-pair block whose +coefficient is the corresponding PBW basis vector in `n` pairs. -/ +theorem presentedPBWBasis_succ_eq_coefficientOrdered + (n : ℕ) (m : PhaseVar (n + 1) →₀ ℕ) : + presentedPBWBasis k (n + 1) m = + presentedCoefficientOrdered k n + (m (.inl (0 : Fin (n + 1)))) + (m (.inr (0 : Fin (n + 1)))) + (presentedPBWBasis k n + (phaseExponent + (fun i => m (.inl i.succ)) + (fun i => m (.inr i.succ)))) := by + rw [presentedPBWBasis_apply, presentedOrderedMonomial, + presentedPBWBasis_apply] + rfl + +theorem extendPhaseExponent_sub_newestMomentum_general + (n a p : ℕ) (m : PhaseVar n →₀ ℕ) : + extendPhaseExponent n a p m - + Finsupp.single (.inr (0 : Fin (n + 1))) 1 = + extendPhaseExponent n a (p - 1) m := by + classical + have hnew : (Finsupp.mapDomain oldIndex m) + (.inr (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨i, hi⟩ + cases i <;> simp [oldIndex, Fin.succ_ne_zero] at hi + ext i + rcases i with i | i + · by_cases hi : i = 0 + · subst i + simp [extendPhaseExponent, oldIndex, + add_comm, add_left_comm, add_assoc] + · simp [extendPhaseExponent, oldIndex, hi, + add_comm, add_left_comm, add_assoc] + · by_cases hi : i = 0 + · subst i + simp [extendPhaseExponent, oldIndex, hnew] + · have h0i : (0 : Fin (n + 1)) ≠ i := Ne.symm hi + simp [extendPhaseExponent, oldIndex, hi, h0i, + add_comm, add_left_comm, add_assoc] + +theorem extendPhaseExponent_newestMomentum_apply + (n a p : ℕ) (m : PhaseVar n →₀ ℕ) : + extendPhaseExponent n a p m (.inr (0 : Fin (n + 1))) = p := by + have hnew : (Finsupp.mapDomain oldIndex m) + (.inr (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨i, hi⟩ + cases i <;> simp [oldIndex, Fin.succ_ne_zero] at hi + simp [extendPhaseExponent, oldIndex, hnew] + +theorem coordinate_symbol_linear_maps_eq (n T : ℕ) : + coordinateCommutatorPrincipalLinear k n T = + coordinatePoissonPrincipalLinear k n T := by + apply Module.Basis.ext (presentedPBWBasis k (n + 1)) + intro m + let a := m (.inl (0 : Fin (n + 1))) + let p := m (.inr (0 : Fin (n + 1))) + let mold : PhaseVar n →₀ ℕ := + phaseExponent + (fun i => m (.inl i.succ)) + (fun i => m (.inr i.succ)) + rw [presentedPBWBasis_succ_eq_coefficientOrdered k n m] + change presentedPrincipalComponent k orderWeight T + (Stafford.commutator (presentedCoordinate k n) + (presentedCoefficientOrdered k n a p + (presentedPBWBasis k n mold))) = + -MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (presentedPrincipalComponent k orderWeight (T + 1) + (presentedCoefficientOrdered k n a p + (presentedPBWBasis k n mold))) + rw [presentedCoordinate_commutator_coefficientOrdered] + simp only [map_neg, map_smul] + change -((p : k) • + MvPolynomial.weightedHomogeneousComponent orderWeight T + (presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a (p - 1) + (presentedPBWBasis k n mold)))) = + -MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (MvPolynomial.weightedHomogeneousComponent orderWeight (T + 1) + (presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p + (presentedPBWBasis k n mold)))) + rw [show presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a (p - 1) + (presentedPBWBasis k n mold)) = + MvPolynomial.monomial + (extendPhaseExponent n a (p - 1) mold) 1 from + presentedCoefficientOrdered_basis_normal k n a (p - 1) mold, + weightedHomogeneousComponent_monomial, + show presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p + (presentedPBWBasis k n mold)) = + MvPolynomial.monomial (extendPhaseExponent n a p mold) 1 from + presentedCoefficientOrdered_basis_normal k n a p mold, + weightedHomogeneousComponent_monomial] + let q := extendPhaseExponent n a p mold + let q' := extendPhaseExponent n a (p - 1) mold + change -((p : k) • + (if monomialWeight orderWeight q' = T then + MvPolynomial.monomial q' 1 else 0)) = + -MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (if monomialWeight orderWeight q = T + 1 then + MvPolynomial.monomial q 1 else 0) + by_cases hp : p = 0 + · simp [hp, q, q', MvPolynomial.pderiv_monomial, + extendPhaseExponent_newestMomentum_apply] + split <;> simp [MvPolynomial.pderiv_monomial, + extendPhaseExponent_newestMomentum_apply] + · have hp0 : 0 < p := Nat.pos_of_ne_zero hp + have hweight : + monomialWeight orderWeight q = + monomialWeight orderWeight q' + 1 := by + dsimp [q, q'] + rw [← monomialWeight_extend_order, ← monomialWeight_extend_order] + omega + by_cases hq : monomialWeight orderWeight q = T + 1 + · have hq' : monomialWeight orderWeight q' = T := by omega + rw [if_pos hq, if_pos hq', MvPolynomial.pderiv_monomial, + extendPhaseExponent_newestMomentum_apply, + extendPhaseExponent_sub_newestMomentum_general] + rw [MvPolynomial.smul_monomial] + simp [q'] + · have hq' : monomialWeight orderWeight q' ≠ T := by + intro h + apply hq + omega + rw [if_neg hq, if_neg hq'] + simp + +/-- For every presented Weyl element and every homogeneous order degree, the +symbol of commutation with the newest coordinate is the negative Poisson +bracket with its coordinate symbol. No filtration-bound hypothesis on `w` +is required. -/ +theorem principalComponent_coordinate_commutator_arbitrary + (n T : ℕ) (w : PresentedWeyl k (n + 1)) : + presentedPrincipalComponent k (@orderWeight (n + 1)) T + (Stafford.commutator (presentedCoordinate k n) w) = + -poissonBracket (MvPolynomial.X (.inl (0 : Fin (n + 1)))) + (presentedPrincipalComponent k (@orderWeight (n + 1)) (T + 1) w) := by + have h := LinearMap.congr_fun (coordinate_symbol_linear_maps_eq k n T) w + change _ = -MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (presentedPrincipalComponent k orderWeight (T + 1) w) at h + rw [poissonBracket_newestCoordinate] + exact h + + +end + +end Stafford38.WeylCoordinateCommutatorSymbol diff --git a/LeanPool/Stafford38/Stafford38/Weyl/EulerRemainder.lean b/LeanPool/Stafford38/Stafford38/Weyl/EulerRemainder.lean new file mode 100644 index 0000000000..6e02cf06b9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/EulerRemainder.lean @@ -0,0 +1,447 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.EulerSubring +import LeanPool.Stafford38.Stafford38.Weyl.EulerResidue +import LeanPool.Stafford38.Stafford38.Weyl.OuterOreMonic + +/-! +# Positive outer-Ore remainders + +An element whose outer momentum support is strictly below `N` acquires a +right coordinate factor after multiplication by `x^N` on either side. The +cofactors remain in the concrete Euler subring. +-/ + +namespace Stafford38.WeylEulerRemainder + +open Polynomial +open Stafford +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open AlgebraicAnalysis.OreAssociativity +open Stafford38.OreCoordinateStage +open Stafford38.OrePairStage +open Stafford38.WeylEulerSubring +open Stafford38.WeylEulerResidue +open Stafford38.EulerSurjectivity + +noncomputable section + + +variable (B : Type*) [Ring B] [Algebra ℚ B] + +local instance : Algebra ℚ (CoordinateStage (B := B)) := + coordinateStageAlgebra + +local instance : Algebra ℚ (PairStage (B := B)) := + pairStageAlgebra + +/-- Both products by `x^N` have a right `x` factor with cofactor in the Euler +subring. -/ +def HasPositiveCoordinateFactor (N : ℕ) (z : PairStage (B := B)) : Prop := + ∃ U V : pairEulerSubring B, + z * pairCoordinate ^ N = (U : PairStage (B := B)) * pairCoordinate ∧ + pairCoordinate ^ N * z = (V : PairStage (B := B)) * pairCoordinate + +omit [Algebra ℚ B] in +lemma hasPositiveCoordinateFactor_zero (N : ℕ) : + HasPositiveCoordinateFactor B N 0 := by + exact ⟨0, 0, by simp, by simp⟩ + +omit [Algebra ℚ B] in +lemma hasPositiveCoordinateFactor_add {N : ℕ} {z w : PairStage (B := B)} + (hz : HasPositiveCoordinateFactor B N z) + (hw : HasPositiveCoordinateFactor B N w) : + HasPositiveCoordinateFactor B N (z + w) := by + obtain ⟨Uz, Vz, hz₁, hz₂⟩ := hz + obtain ⟨Uw, Vw, hw₁, hw₂⟩ := hw + refine ⟨Uz + Uw, Vz + Vw, ?_, ?_⟩ + · simpa only [add_mul, Subring.coe_add] using congrArg₂ (· + ·) hz₁ hw₁ + · simpa only [mul_add, add_mul, Subring.coe_add] using congrArg₂ (· + ·) hz₂ hw₂ + +omit [Algebra ℚ B] in +lemma pairCoordinate_pow_mul_coefficient (b : B) : ∀ N : ℕ, + pairCoordinate ^ N * pairCoefficient b = + pairCoefficient b * pairCoordinate ^ N + | 0 => by simp + | N + 1 => by + calc + pairCoordinate ^ (N + 1) * pairCoefficient b = + (pairCoordinate ^ N * pairCoordinate) * pairCoefficient b := by + rw [pow_succ] + _ = pairCoordinate ^ N * (pairCoordinate * pairCoefficient b) := by + rw [mul_assoc] + _ = pairCoordinate ^ N * (pairCoefficient b * pairCoordinate) := by + rw [pairCoordinate_mul_coefficient] + _ = (pairCoordinate ^ N * pairCoefficient b) * pairCoordinate := by + rw [mul_assoc] + _ = pairCoefficient b * pairCoordinate ^ (N + 1) := by + rw [pairCoordinate_pow_mul_coefficient b N, pow_succ, mul_assoc] + +/-- A single ordered monomial with outer momentum exponent below `N` has the +two required positive factorizations. -/ +theorem pairOrderedMonomial_hasPositiveCoordinateFactor + (b : B) (a j N : ℕ) (hjN : j < N) : + HasPositiveCoordinateFactor B N + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j) := by + obtain ⟨f, hf⟩ := exists_eulerPolynomial_d_pow_mul_x_pow + (A := PairStage (B := B)) pairCoordinate pairMomentum + pairMomentum_mul_coordinate j + have hpoly : eulerPolynomialEval pairCoordinate pairMomentum f ∈ + pairEulerSubring B := + eulerPolynomialEval_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum (rational_mem_pairOldSubring B) f + have hb : pairCoefficient b ∈ pairEulerSubring B := + coefficient_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum ⟨pairCoefficient b, ⟨b, rfl⟩⟩ + have hxa : pairCoordinate ^ a ∈ pairEulerSubring B := + (pairEulerSubring B).pow_mem + (coordinate_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum) a + have hxleft : pairCoordinate ^ (N - j - 1) ∈ pairEulerSubring B := + (pairEulerSubring B).pow_mem + (coordinate_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum) (N - j - 1) + let U : pairEulerSubring B := + ⟨pairCoefficient b * pairCoordinate ^ a * + eulerPolynomialEval pairCoordinate pairMomentum f * + pairCoordinate ^ (N - j - 1), + (pairEulerSubring B).mul_mem + ((pairEulerSubring B).mul_mem + ((pairEulerSubring B).mul_mem hb hxa) hpoly) hxleft⟩ + obtain ⟨V, hV⟩ := + pairOrderedMonomial_eq_eulerSubring_mul_coordinate B b (N + a) j + (by omega) + refine ⟨U, V, ?_, ?_⟩ + · have hpowN : (pairCoordinate (B := B)) ^ N = + pairCoordinate ^ j * pairCoordinate ^ (N - j) := by + rw [← pow_add, Nat.add_sub_of_le (Nat.le_of_lt hjN)] + have hpowDiff : (pairCoordinate (B := B)) ^ (N - j) = + pairCoordinate ^ (N - j - 1) * pairCoordinate := by + calc + pairCoordinate ^ (N - j) = + pairCoordinate ^ ((N - j - 1) + 1) := by congr 1; omega + _ = pairCoordinate ^ (N - j - 1) * pairCoordinate := by + rw [pow_add, pow_one] + change + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j) * + pairCoordinate ^ N = + (pairCoefficient b * pairCoordinate ^ a * + eulerPolynomialEval pairCoordinate pairMomentum f * + pairCoordinate ^ (N - j - 1)) * pairCoordinate + calc + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j) * + pairCoordinate ^ N = + pairCoefficient b * pairCoordinate ^ a * + (pairMomentum ^ j * pairCoordinate ^ j) * + pairCoordinate ^ (N - j) := by + rw [hpowN] + simp only [mul_assoc] + _ = pairCoefficient b * pairCoordinate ^ a * + eulerPolynomialEval pairCoordinate pairMomentum f * + pairCoordinate ^ (N - j) := by + rw [hf] + _ = (pairCoefficient b * pairCoordinate ^ a * + eulerPolynomialEval pairCoordinate pairMomentum f * + pairCoordinate ^ (N - j - 1)) * pairCoordinate := by + rw [hpowDiff] + simp only [mul_assoc] + · calc + pairCoordinate ^ N * + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j) = + pairCoefficient b * pairCoordinate ^ (N + a) * pairMomentum ^ j := by + calc + pairCoordinate ^ N * + (pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j) = + (pairCoordinate ^ N * pairCoefficient b) * + pairCoordinate ^ a * pairMomentum ^ j := by + simp only [mul_assoc] + _ = (pairCoefficient b * pairCoordinate ^ N) * + pairCoordinate ^ a * pairMomentum ^ j := by + rw [pairCoordinate_pow_mul_coefficient B b N] + _ = pairCoefficient b * pairCoordinate ^ (N + a) * + pairMomentum ^ j := by + rw [pow_add] + simp only [mul_assoc] + _ = (V : PairStage (B := B)) * pairCoordinate := hV + +private lemma coordinateCoefficientTerm_hasPositive + (c : CoordinateStage (B := B)) (j N : ℕ) (hjN : j < N) : + HasPositiveCoordinateFactor B N + (normalCoefficient coordinateDerivation c * pairMomentum ^ j) := by + let q := (normalFormAddEquiv (zeroDerivation (B := B))).symm c + have hc : c = normalForm (zeroDerivation (B := B)) q := by + exact (normalFormAddEquiv (zeroDerivation (B := B))).apply_symm_apply c |>.symm + rw [hc] + induction q using Polynomial.induction_on' with + | add q r hq hr => + rw [normalForm_add, + (normalCoefficient (coordinateDerivation (B := B))).map_add, add_mul] + exact hasPositiveCoordinateFactor_add (B := B) hq hr + | monomial a b => + rw [normalForm_monomial, + (normalCoefficient (coordinateDerivation (B := B))).map_mul, + (normalCoefficient (coordinateDerivation (B := B))).map_pow] + exact pairOrderedMonomial_hasPositiveCoordinateFactor B b a j N hjN + +/-- Every element whose outer momentum support lies below `N` has both +positive right-coordinate factorizations. -/ +theorem hasPositiveCoordinateFactor_of_outer_support + (z : PairStage (B := B)) (N : ℕ) + (hsupport : ∀ j ∈ + ((normalFormAddEquiv coordinateDerivation).symm z).support, j < N) : + HasPositiveCoordinateFactor B N z := by + let q := (normalFormAddEquiv coordinateDerivation).symm z + have hz : z = normalForm coordinateDerivation q := by + exact (normalFormAddEquiv coordinateDerivation).apply_symm_apply z |>.symm + rw [hz, ← Polynomial.sum_monomial_eq q] + change HasPositiveCoordinateFactor B N + (normalFormAddHom (coordinateDerivation (B := B)) + (∑ j ∈ q.support, Polynomial.monomial j (q.coeff j))) + rw [map_sum] + refine Finset.sum_induction (M := PairStage (B := B)) + (fun j => normalFormAddHom (coordinateDerivation (B := B)) + (Polynomial.monomial j (q.coeff j))) + (HasPositiveCoordinateFactor B N) ?_ ?_ ?_ + · intro a b ha hb + exact hasPositiveCoordinateFactor_add (B := B) ha hb + · exact hasPositiveCoordinateFactor_zero B N + · intro j hj + change HasPositiveCoordinateFactor B N + (normalForm (coordinateDerivation (B := B)) + (Polynomial.monomial j (q.coeff j))) + rw [normalForm_monomial] + exact coordinateCoefficientTerm_hasPositive B (q.coeff j) j N + (hsupport j hj) + +omit [Algebra ℚ B] in +lemma support_sub_X_pow_lt + (H : Polynomial (CoordinateStage (B := B))) (N : ℕ) + (hN : H.coeff N = 1) + (hgt : ∀ j, N < j → H.coeff j = 0) : + ∀ j ∈ (H - Polynomial.X ^ N).support, j < N := by + intro j hj + by_contra hnot + have hle : N ≤ j := Nat.le_of_not_gt hnot + have hcoeff : (H - Polynomial.X ^ N).coeff j = 0 := by + rcases hle.eq_or_lt with rfl | hlt + · simp [hN] + · rw [Polynomial.coeff_sub, hgt j hlt] + simp [Polynomial.coeff_X_pow, hlt.ne'] + exact (Polynomial.mem_support_iff.mp hj) hcoeff + +/-- Subtracting the monic outer power leaves an element to which the positive +factor theorem applies. -/ +theorem normalForm_sub_X_pow_hasPositiveCoordinateFactor + (H : Polynomial (CoordinateStage (B := B))) (N : ℕ) + (hN : H.coeff N = 1) + (hgt : ∀ j, N < j → H.coeff j = 0) : + HasPositiveCoordinateFactor B N + (normalForm (coordinateDerivation (B := B)) + (H - Polynomial.X ^ N)) := by + apply hasPositiveCoordinateFactor_of_outer_support B + intro j hj + change j ∈ ((normalFormAddEquiv (coordinateDerivation (B := B))).symm + ((normalFormAddEquiv (coordinateDerivation (B := B))) + (H - Polynomial.X ^ N))).support at hj + rw [(normalFormAddEquiv (coordinateDerivation (B := B))).symm_apply_apply] at hj + exact support_sub_X_pow_lt B H N hN hgt j hj + +/-- The positive-factor interface turns the explicit Euler residue into the +exact shaped residue consumed by quotient surjectivity. -/ +theorem positiveEulerResidue_eq_eulerSubring_mul_coordinate + (d sigma : PairStage (B := B)) (N : ℕ) + (hd : d = pairMomentum ^ N + sigma) + (hpositive : HasPositiveCoordinateFactor B N sigma) : + ∃ U : pairEulerSubring B, + 1 + (U : PairStage (B := B)) * pairCoordinate ∈ + canonicalRightIdeal pairCoordinate d N := by + obtain ⟨u, v, hmem⟩ := positiveEulerResidue_polynomial_mem + pairCoordinate pairMomentum d sigma N pairMomentum_mul_coordinate hd + obtain ⟨U, V, hright, hleft⟩ := hpositive + obtain ⟨su, hsu⟩ := coordinate_mul_eulerPolynomial + (pairOldSubring B) pairCoordinate pairMomentum + pairMomentum_mul_coordinate (pairOldSubring_commutes_coordinate B) + (rational_mem_pairOldSubring B) u + obtain ⟨sv, hsv⟩ := coordinate_mul_eulerPolynomial + (pairOldSubring B) pairCoordinate pairMomentum + pairMomentum_mul_coordinate (pairOldSubring_commutes_coordinate B) + (rational_mem_pairOldSubring B) v + refine ⟨U * su + V * sv, ?_⟩ + convert hmem using 1 + simp only [Subring.coe_add, Subring.coe_mul, add_mul] + rw [hright, hleft] + simp only [mul_assoc] + rw [hsu, hsv] + +omit [Algebra ℚ B] in +private lemma coordinateCoefficient_mem_pairGeneratorSubring + (c : CoordinateStage (B := B)) : + normalCoefficient coordinateDerivation c ∈ + Subring.closure (((pairOldSubring B : Subring (PairStage (B := B))) : + Set (PairStage (B := B))) ∪ {pairCoordinate, pairMomentum}) := by + let q := (normalFormAddEquiv (zeroDerivation (B := B))).symm c + have hc : c = normalForm (zeroDerivation (B := B)) q := by + exact (normalFormAddEquiv (zeroDerivation (B := B))).apply_symm_apply c |>.symm + rw [hc] + induction q using Polynomial.induction_on' with + | add q r hq hr => + rw [normalForm_add, + (normalCoefficient (coordinateDerivation (B := B))).map_add] + exact Subring.add_mem _ hq hr + | monomial a b => + rw [normalForm_monomial, + (normalCoefficient (coordinateDerivation (B := B))).map_mul, + (normalCoefficient (coordinateDerivation (B := B))).map_pow] + apply Subring.mul_mem + · apply Subring.subset_closure + exact Or.inl ⟨b, rfl⟩ + · apply Subring.pow_mem + apply Subring.subset_closure + exact Or.inr (Or.inl rfl) + +/-- The old coefficient ring together with the new coordinate and momentum +generates the complete pair stage. -/ +theorem closure_pairOldSubring_union_coordinate_momentum_eq_top : + Subring.closure (((pairOldSubring B : Subring (PairStage (B := B))) : + Set (PairStage (B := B))) ∪ {pairCoordinate, pairMomentum}) = ⊤ := by + apply top_unique + intro z hz + let q := (normalFormAddEquiv (coordinateDerivation (B := B))).symm z + have hzq : z = normalForm coordinateDerivation q := by + exact (normalFormAddEquiv coordinateDerivation).apply_symm_apply z |>.symm + rw [hzq] + induction q using Polynomial.induction_on' with + | add q r hq hr => + rw [normalForm_add] + exact Subring.add_mem _ hq hr + | monomial j c => + rw [normalForm_monomial] + apply Subring.mul_mem + · exact coordinateCoefficient_mem_pairGeneratorSubring B c + · apply Subring.pow_mem + apply Subring.subset_closure + exact Or.inr (Or.inr rfl) + + +section Presented + +open Stafford38.OreIteratedPairStage +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylOuterOreMonic +open Stafford38.WeylPBWMonicBridge + +universe u + +variable (k : Type u) [Field k] [Algebra ℚ k] + +local instance iteratedRatAlgebra : + (n : ℕ) → Algebra ℚ (IteratedPairStage k n) + | 0 => by + change Algebra ℚ k + infer_instance + | n + 1 => by + letI : Algebra ℚ (IteratedPairStage k n) := iteratedRatAlgebra n + change Algebra ℚ (PairStage (B := IteratedPairStage k n)) + exact pairStageAlgebra + +local instance (n : ℕ) : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + +local instance (n : ℕ) : + Algebra ℚ (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + +local instance (n : ℕ) : + Algebra ℚ (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + +/-- The concrete remainder of a normalized presented Weyl operator satisfies +both positive-coordinate factorizations. -/ +theorem presentedRemainder_hasPositiveCoordinateFactor + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + HasPositiveCoordinateFactor (IteratedPairStage k n) N + (presentedToIterated k (n + 1) d - stageMomentum k n ^ N) := by + let H := presentedOuterPolynomial k n d + have hpositive := normalForm_sub_X_pow_hasPositiveCoordinateFactor + (IteratedPairStage k n) H N + (outer_coeff_eq_one_at_bound k n N hd) + (fun j hj => outer_coeff_eq_zero_of_exponent_gt k n N hd hj) + have hnormal : + normalForm (coordinateDerivation (B := IteratedPairStage k n)) + (H - Polynomial.X ^ N) = + presentedToIterated k (n + 1) d - stageMomentum k n ^ N := by + change normalFormAddHom coordinateDerivation (H - Polynomial.X ^ N) = _ + have hH : normalForm (coordinateDerivation (B := IteratedPairStage k n)) H = + presentedToIterated k (n + 1) d := by + exact (normalFormAddEquiv coordinateDerivation).apply_symm_apply _ + have hH' : normalFormAddHom coordinateDerivation H = + presentedToIterated k (n + 1) d := hH + rw [map_sub, hH'] + congr 1 + rw [Polynomial.X_pow_eq_monomial] + change normalForm coordinateDerivation (Polynomial.monomial N 1) = _ + rw [normalForm_monomial] + rw [map_one, one_mul] + change pairMomentum (B := IteratedPairStage k n) ^ N = + stageMomentum k n ^ N + rfl + rw [hnormal] at hpositive + exact hpositive + +/-- The normalized presented operator has the exact positive Euler residue in +its literal canonical right ideal. -/ +theorem presentedPositiveEulerResidue + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + ∃ U : pairEulerSubring (IteratedPairStage k n), + 1 + (U : PairStage (B := IteratedPairStage k n)) * pairCoordinate ∈ + canonicalRightIdeal (pairCoordinate (B := IteratedPairStage k n)) + (presentedToIterated k (n + 1) d) N := by + let sigma := presentedToIterated k (n + 1) d - stageMomentum k n ^ N + have hdecomp : presentedToIterated k (n + 1) d = + stageMomentum k n ^ N + sigma := by + simp [sigma] + have hpositive : HasPositiveCoordinateFactor (IteratedPairStage k n) N sigma := + presentedRemainder_hasPositiveCoordinateFactor k n N hd + exact positiveEulerResidue_eq_eulerSubring_mul_coordinate + (IteratedPairStage k n) (presentedToIterated k (n + 1) d) sigma N + hdecomp hpositive + +/-- Right multiplication by the selected coordinate is onto the concrete +canonical quotient. -/ +theorem presentedCanonicalQuotient_rightMul_coordinate_surjective + (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Function.Surjective + (rightMul + (canonicalRightIdeal (pairCoordinate (B := IteratedPairStage k n)) + (presentedToIterated k (n + 1) d) N) + (pairCoordinate (B := IteratedPairStage k n))) := by + apply rightMul_surjective_of_euler_normal + (R := pairEulerSubring (IteratedPairStage k n)) + (p := pairMomentum (B := IteratedPairStage k n)) + · exact coordinate_normal_eulerSubring + (pairOldSubring (IteratedPairStage k n)) + pairCoordinate pairMomentum + (stageMomentum_mul_coordinate k n) + (pairOldSubring_commutes_coordinate (IteratedPairStage k n)) + · exact euler_mem_eulerSubring + (pairOldSubring (IteratedPairStage k n)) + pairCoordinate pairMomentum + · exact presentedPositiveEulerResidue k n N hd + · apply closure_eulerSubring_union_momentum_eq_top + exact closure_pairOldSubring_union_coordinate_momentum_eq_top + (IteratedPairStage k n) + + +end Presented + +end +end Stafford38.WeylEulerRemainder diff --git a/LeanPool/Stafford38/Stafford38/Weyl/EulerResidue.lean b/LeanPool/Stafford38/Stafford38/Weyl/EulerResidue.lean new file mode 100644 index 0000000000..855c6a2b8e --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/EulerResidue.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.proofs.weyl_pure_power + +/-! +# The positive Euler residue in the canonical right ideal + +This module fixes the right-ideal orientation of the Euler Bezout identity. +The remaining step for quotient surjectivity is to prove that the displayed +error term has a right factor `x` lying in the Euler-nonnegative subring. +-/ + +namespace Stafford38.WeylEulerResidue + +open Stafford +open AlgebraicAnalysis + +noncomputable section + +variable {A : Type*} [Ring A] + +/-- The literal right ideal generated by `d` and `x^N d`. -/ +def canonicalRightIdeal (x d : A) (N : ℕ) : Submodule Aᵐᵒᵖ A := + Submodule.span Aᵐᵒᵖ ({d, x ^ N * d} : Set A) + +lemma firstGenerator_mem (x d : A) (N : ℕ) : + d ∈ canonicalRightIdeal x d N := by + apply Submodule.subset_span + simp + +lemma secondGenerator_mem (x d : A) (N : ℕ) : + x ^ N * d ∈ canonicalRightIdeal x d N := by + apply Submodule.subset_span + simp + +/-- Expanding a monic element around the pure momentum power transports the +Euler Bezout identity to an exact positive-residue identity. -/ +theorem positiveEulerResidue_identity + (x p d sigma u v : A) (N : ℕ) + (hd : d = p ^ N + sigma) + (hbezout : (p ^ N * x ^ N) * u + (x ^ N * p ^ N) * v = 1) : + d * (x ^ N * u) + (x ^ N * d) * v = + 1 + ((sigma * x ^ N) * u + (x ^ N * sigma) * v) := by + rw [hd] + calc + (p ^ N + sigma) * (x ^ N * u) + + (x ^ N * (p ^ N + sigma)) * v = + ((p ^ N * x ^ N) * u + (x ^ N * p ^ N) * v) + + ((sigma * x ^ N) * u + (x ^ N * sigma) * v) := by + noncomm_ring + _ = 1 + ((sigma * x ^ N) * u + (x ^ N * sigma) * v) := by + rw [hbezout] + +/-- For a Weyl pair and a monic decomposition `d = p^N + sigma`, the explicit +positive Euler residue belongs to the literal right ideal `dA + x^N dA`. +The cofactors come from the ordinary Bezout identity for the two disjoint +Euler products. -/ +theorem positiveEulerResidue_mem + [Algebra ℚ A] (x p d sigma : A) (N : ℕ) + (hweyl : p * x = x * p + 1) + (hd : d = p ^ N + sigma) : + ∃ u v : A, + 1 + ((sigma * x ^ N) * u + (x ^ N * sigma) * v) ∈ + canonicalRightIdeal x d N := by + obtain ⟨u, v, hbezout⟩ := + euler_products_right_bezout_exists x p hweyl N + refine ⟨u, v, ?_⟩ + have hfirst : d * (x ^ N * u) ∈ canonicalRightIdeal x d N := by + change MulOpposite.op (x ^ N * u) • d ∈ canonicalRightIdeal x d N + exact (canonicalRightIdeal x d N).smul_mem _ + (firstGenerator_mem x d N) + have hsecond : (x ^ N * d) * v ∈ canonicalRightIdeal x d N := by + change MulOpposite.op v • (x ^ N * d) ∈ canonicalRightIdeal x d N + exact (canonicalRightIdeal x d N).smul_mem _ + (secondGenerator_mem x d N) + rw [← positiveEulerResidue_identity x p d sigma u v N hd hbezout] + exact (canonicalRightIdeal x d N).add_mem hfirst hsecond + +/-- The same residue statement with the two cofactors retained explicitly as +rational polynomials in the Euler element `x*p`. -/ +theorem positiveEulerResidue_polynomial_mem + [Algebra ℚ A] (x p d sigma : A) (N : ℕ) + (hweyl : p * x = x * p + 1) + (hd : d = p ^ N + sigma) : + ∃ u v : Polynomial ℚ, + 1 + + ((sigma * x ^ N) * eulerPolynomialEval x p u + + (x ^ N * sigma) * eulerPolynomialEval x p v) ∈ + canonicalRightIdeal x d N := by + obtain ⟨u, v, hbezout⟩ := + euler_products_polynomial_right_bezout_exists x p hweyl N + refine ⟨u, v, ?_⟩ + have hfirst : d * (x ^ N * eulerPolynomialEval x p u) ∈ + canonicalRightIdeal x d N := by + change MulOpposite.op (x ^ N * eulerPolynomialEval x p u) • d ∈ + canonicalRightIdeal x d N + exact (canonicalRightIdeal x d N).smul_mem _ + (firstGenerator_mem x d N) + have hsecond : (x ^ N * d) * eulerPolynomialEval x p v ∈ + canonicalRightIdeal x d N := by + change MulOpposite.op (eulerPolynomialEval x p v) • (x ^ N * d) ∈ + canonicalRightIdeal x d N + exact (canonicalRightIdeal x d N).smul_mem _ + (secondGenerator_mem x d N) + rw [← positiveEulerResidue_identity x p d sigma + (eulerPolynomialEval x p u) (eulerPolynomialEval x p v) N hd hbezout] + exact (canonicalRightIdeal x d N).add_mem hfirst hsecond + + +end +end Stafford38.WeylEulerResidue diff --git a/LeanPool/Stafford38/Stafford38/Weyl/EulerSubring.lean b/LeanPool/Stafford38/Stafford38/Weyl/EulerSubring.lean new file mode 100644 index 0000000000..867ef7b124 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/EulerSubring.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Quotient.EulerSurjectivity +import LeanPool.Stafford38.Stafford38.Ore.PairStage +import LeanPool.Stafford38.proofs.weyl_pure_power + +/-! +# The Euler-nonnegative generated subring + +This file isolates the formal normality argument. Given a coefficient subring +commuting with a Weyl coordinate `x`, the subring generated by the +coefficients, `x`, and `E = x*p` satisfies `x*R ⊆ R*x`. +-/ + +namespace Stafford38.WeylEulerSubring + +noncomputable section + +variable {A : Type*} [Ring A] + +/-- The subring generated by transverse coefficients, the coordinate, and the +Euler element. In the concrete Weyl tower this is the Euler-nonnegative +subring used by the quotient argument. -/ +def eulerSubring (C : Subring A) (x p : A) : Subring A := + Subring.closure ((C : Set A) ∪ {x, x * p}) + +/-- Elements that can cross `x` from right to left while retaining a +cofactor in `R`. -/ +def normalAcross (R : Subring A) (x : A) : Subring A where + carrier := {a | ∃ s : R, x * a = (s : A) * x} + zero_mem' := ⟨0, by simp⟩ + one_mem' := ⟨1, by simp⟩ + add_mem' := by + rintro a b ⟨s, hs⟩ ⟨t, ht⟩ + refine ⟨s + t, ?_⟩ + simp only [Subring.coe_add] + rw [mul_add, hs, ht, add_mul] + neg_mem' := by + rintro a ⟨s, hs⟩ + refine ⟨-s, ?_⟩ + simp only [Subring.coe_neg] + rw [mul_neg, hs, neg_mul] + mul_mem' := by + rintro a b ⟨s, hs⟩ ⟨t, ht⟩ + refine ⟨s * t, ?_⟩ + simp only [Subring.coe_mul] + calc + x * (a * b) = (x * a) * b := by rw [mul_assoc] + _ = ((s : A) * x) * b := by rw [hs] + _ = (s : A) * (x * b) := by rw [mul_assoc] + _ = (s : A) * ((t : A) * x) := by rw [ht] + _ = ((s : A) * (t : A)) * x := by rw [mul_assoc] + +lemma coefficient_mem_eulerSubring (C : Subring A) (x p : A) (c : C) : + (c : A) ∈ eulerSubring C x p := by + apply Subring.subset_closure + exact Or.inl c.property + +lemma coordinate_mem_eulerSubring (C : Subring A) (x p : A) : + x ∈ eulerSubring C x p := by + apply Subring.subset_closure + exact Or.inr (by simp) + +lemma euler_mem_eulerSubring (C : Subring A) (x p : A) : + x * p ∈ eulerSubring C x p := by + apply Subring.subset_closure + exact Or.inr (by simp) + +/-- One-sided normality of the Euler subring. -/ +theorem coordinate_normal_eulerSubring + (C : Subring A) (x p : A) + (hweyl : p * x = x * p + 1) + (hcomm : ∀ c : C, x * (c : A) = (c : A) * x) : + ∀ r : eulerSubring C x p, + ∃ s : eulerSubring C x p, x * (r : A) = (s : A) * x := by + intro r + have hle : eulerSubring C x p ≤ normalAcross (eulerSubring C x p) x := by + apply Subring.closure_le.2 + intro a ha + rcases ha with ha | ha + · exact ⟨⟨a, coefficient_mem_eulerSubring C x p ⟨a, ha⟩⟩, + hcomm ⟨a, ha⟩⟩ + · simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at ha + rcases ha with hx | hE + · refine ⟨⟨x, coordinate_mem_eulerSubring C x p⟩, ?_⟩ + calc + x * a = x * x := by rw [hx] + _ = (x : A) * x := rfl + · refine ⟨⟨x * p - 1, ?_⟩, ?_⟩ + · exact (eulerSubring C x p).sub_mem + (euler_mem_eulerSubring C x p) + (eulerSubring C x p).one_mem + · calc + x * a = x * (x * p) := by rw [hE] + _ = x * (p * x - 1) := by rw [hweyl]; noncomm_ring + _ = (x * p - 1) * x := by noncomm_ring + exact hle r.property + +/-- If the ambient ring is generated by the coefficient subring and the Weyl +pair, adjoining `p` to the Euler subring still generates the ambient ring. -/ +theorem closure_eulerSubring_union_momentum_eq_top + (C : Subring A) (x p : A) + (hgenerate : Subring.closure ((C : Set A) ∪ {x, p}) = ⊤) : + Subring.closure (((eulerSubring C x p : Subring A) : Set A) ∪ {p}) = ⊤ := by + apply top_unique + rw [← hgenerate] + apply Subring.closure_le.2 + intro a ha + rcases ha with ha | ha + · apply Subring.subset_closure + show a ∈ ((eulerSubring C x p : Subring A) : Set A) ∪ {p} + exact Or.inl (coefficient_mem_eulerSubring C x p ⟨a, ha⟩) + · simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at ha + rcases ha with hx | hp + · apply Subring.subset_closure + show a ∈ ((eulerSubring C x p : Subring A) : Set A) ∪ {p} + refine Or.inl ?_ + change a ∈ eulerSubring C x p + rw [hx] + exact coordinate_mem_eulerSubring C x p + · apply Subring.subset_closure + show a ∈ ((eulerSubring C x p : Subring A) : Set A) ∪ {p} + exact Or.inr (by simpa only [Set.mem_singleton_iff] using hp) + +section RationalEulerPolynomials + +variable [Algebra ℚ A] + +/-- Rational Euler polynomials lie in the Euler subring whenever the +coefficient subring contains the rational scalars. -/ +theorem eulerPolynomialEval_mem_eulerSubring + (C : Subring A) (x p : A) + (hscalar : ∀ q : ℚ, algebraMap ℚ A q ∈ C) + (f : Polynomial ℚ) : + Stafford.eulerPolynomialEval x p f ∈ eulerSubring C x p := by + induction f using Polynomial.induction_on' with + | add f g hf hg => + rw [map_add] + exact (eulerSubring C x p).add_mem hf hg + | monomial n q => + rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow, + Stafford.eulerPolynomialEval_C, + Stafford.eulerPolynomialEval_X] + exact (eulerSubring C x p).mul_mem + (coefficient_mem_eulerSubring C x p ⟨algebraMap ℚ A q, hscalar q⟩) + ((eulerSubring C x p).pow_mem + (euler_mem_eulerSubring C x p) n) + +/-- Euler polynomials cross the coordinate with a cofactor that remains in +the Euler subring. -/ +theorem coordinate_mul_eulerPolynomial + (C : Subring A) (x p : A) + (hweyl : p * x = x * p + 1) + (hcomm : ∀ c : C, x * (c : A) = (c : A) * x) + (hscalar : ∀ q : ℚ, algebraMap ℚ A q ∈ C) + (f : Polynomial ℚ) : + ∃ s : eulerSubring C x p, + x * Stafford.eulerPolynomialEval x p f = (s : A) * x := by + let r : eulerSubring C x p := + ⟨Stafford.eulerPolynomialEval x p f, + eulerPolynomialEval_mem_eulerSubring C x p hscalar f⟩ + exact coordinate_normal_eulerSubring C x p hweyl hcomm r + +end RationalEulerPolynomials + +section PairStage + +open Stafford38.OrePairStage + +variable (B : Type*) [Ring B] [Algebra ℚ B] + +local instance : Algebra ℚ (Stafford38.OreCoordinateStage.CoordinateStage (B := B)) := + coordinateStageAlgebra + +local instance : Algebra ℚ (PairStage (B := B)) := + pairStageAlgebra + +/-- The embedded transverse coefficient ring inside one pair stage. -/ +def pairOldSubring : Subring (PairStage (B := B)) := + RingHom.range (pairCoefficient (B := B)) + +/-- The concrete Euler subring of one pair stage. -/ +abbrev pairEulerSubring : Subring (PairStage (B := B)) := + eulerSubring (pairOldSubring B) pairCoordinate pairMomentum + +omit [Algebra ℚ B] in +lemma pairOldSubring_commutes_coordinate (c : pairOldSubring B) : + pairCoordinate * (c : PairStage (B := B)) = + (c : PairStage (B := B)) * pairCoordinate := by + obtain ⟨b, hb⟩ := c.property + rw [← hb] + exact pairCoordinate_mul_coefficient b + +lemma rational_mem_pairOldSubring (q : ℚ) : + algebraMap ℚ (PairStage (B := B)) q ∈ pairOldSubring B := by + refine ⟨algebraMap ℚ B q, ?_⟩ + exact DFunLike.congr_fun + (pairStageAlgebra_algebraMap (k := ℚ) (B := B)) q |>.symm + +/-- Every ordered pair-stage monomial with at least as many coordinates as +momenta belongs to the Euler subring. -/ +theorem pairOrderedMonomial_mem_eulerSubring + (b : B) (a j : ℕ) (hja : j ≤ a) : + pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j ∈ + pairEulerSubring B := by + obtain ⟨f, hf⟩ := Stafford.exists_eulerPolynomial_x_pow_mul_d_pow + (A := PairStage (B := B)) pairCoordinate pairMomentum + pairMomentum_mul_coordinate j + have hb : pairCoefficient b ∈ pairEulerSubring B := + coefficient_mem_eulerSubring (pairOldSubring B) pairCoordinate pairMomentum + ⟨pairCoefficient b, ⟨b, rfl⟩⟩ + have hx : pairCoordinate ^ (a - j) ∈ pairEulerSubring B := + (pairEulerSubring B).pow_mem + (coordinate_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum) (a - j) + have hfmem : Stafford.eulerPolynomialEval pairCoordinate pairMomentum f ∈ + pairEulerSubring B := + eulerPolynomialEval_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum (rational_mem_pairOldSubring B) f + have hfactor : + pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j = + pairCoefficient b * pairCoordinate ^ (a - j) * + Stafford.eulerPolynomialEval pairCoordinate pairMomentum f := by + rw [hf] + conv_lhs => + rw [show a = (a - j) + j by omega, pow_add] + noncomm_ring + rw [hfactor] + exact (pairEulerSubring B).mul_mem + ((pairEulerSubring B).mul_mem hb hx) hfmem + +/-- Every ordered pair-stage monomial with strictly more coordinates than +momenta has a right coordinate factor whose cofactor remains in the Euler +subring. -/ +theorem pairOrderedMonomial_eq_eulerSubring_mul_coordinate + (b : B) (a j : ℕ) (hja : j < a) : + ∃ U : pairEulerSubring B, + pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j = + (U : PairStage (B := B)) * pairCoordinate := by + obtain ⟨f, hf⟩ := Stafford.exists_eulerPolynomial_x_pow_mul_d_pow + (A := PairStage (B := B)) pairCoordinate pairMomentum + pairMomentum_mul_coordinate j + obtain ⟨s, hs⟩ := coordinate_mul_eulerPolynomial + (pairOldSubring B) pairCoordinate pairMomentum + pairMomentum_mul_coordinate (pairOldSubring_commutes_coordinate B) + (rational_mem_pairOldSubring B) f + have hb : pairCoefficient b ∈ pairEulerSubring B := + coefficient_mem_eulerSubring (pairOldSubring B) pairCoordinate pairMomentum + ⟨pairCoefficient b, ⟨b, rfl⟩⟩ + have hx : pairCoordinate ^ (a - j - 1) ∈ pairEulerSubring B := + (pairEulerSubring B).pow_mem + (coordinate_mem_eulerSubring (pairOldSubring B) + pairCoordinate pairMomentum) (a - j - 1) + let U : pairEulerSubring B := + ⟨pairCoefficient b * pairCoordinate ^ (a - j - 1) * (s : PairStage (B := B)), + (pairEulerSubring B).mul_mem ((pairEulerSubring B).mul_mem hb hx) s.property⟩ + refine ⟨U, ?_⟩ + change pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j = + (pairCoefficient b * pairCoordinate ^ (a - j - 1) * + (s : PairStage (B := B))) * pairCoordinate + calc + pairCoefficient b * pairCoordinate ^ a * pairMomentum ^ j = + pairCoefficient b * pairCoordinate ^ (a - j - 1) * + (pairCoordinate * (pairCoordinate ^ j * pairMomentum ^ j)) := by + have ha : a = (a - j - 1) + 1 + j := by omega + conv_lhs => rw [ha, pow_add, pow_add] + simp only [pow_one] + simp only [mul_assoc] + _ = pairCoefficient b * pairCoordinate ^ (a - j - 1) * + (pairCoordinate * Stafford.eulerPolynomialEval + pairCoordinate pairMomentum f) := by rw [hf] + _ = pairCoefficient b * pairCoordinate ^ (a - j - 1) * + ((s : PairStage (B := B)) * pairCoordinate) := by rw [hs] + _ = (pairCoefficient b * pairCoordinate ^ (a - j - 1) * + (s : PairStage (B := B))) * pairCoordinate := by + simp only [mul_assoc] + + +end PairStage + + +end +end Stafford38.WeylEulerSubring diff --git a/LeanPool/Stafford38/Stafford38/Weyl/FilteredCommutator.lean b/LeanPool/Stafford38/Stafford38/Weyl/FilteredCommutator.lean new file mode 100644 index 0000000000..b5a77cd4e6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/FilteredCommutator.lean @@ -0,0 +1,382 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.AssociatedGraded + +/-! +# Filtered commutators and subprincipal symbols + +This file develops the two-element commutator calculus for the differential- +order filtration. The first theorem is the exact filtration drop for arbitrary +filtered elements; it includes the degree-zero case rather than hiding natural- +number truncation behind a positivity hypothesis. +-/ + +namespace Stafford38.WeylFilteredCommutator + +open Stafford38.Characteristic +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Commutators lower differential order by one. With natural-number +filtration indices, the `r = s = 0` case says that two order-zero operators +commute and hence their commutator belongs to `F₀`. -/ +theorem commutator_mem_orderPiece_pred + {n r s : ℕ} {a b : PresentedWeyl k n} + (ha : a ∈ orderPiece k n r) (hb : b ∈ orderPiece k n s) : + Stafford.commutator a b ∈ orderPiece k n (r + s - 1) := by + have hab : a * b ∈ orderPiece k n (r + s) := + mul_mem_orderPiece k ha hb + have hba : b * a ∈ orderPiece k n (s + r) := + mul_mem_orderPiece k hb ha + have hba' : b * a ∈ orderPiece k n (r + s) := by + simpa [Nat.add_comm] using hba + have hcomm : Stafford.commutator a b ∈ orderPiece k n (r + s) := by + exact Submodule.sub_mem _ hab hba' + have hmulba : + presentedPrincipalComponent k (@orderWeight n) (r + s) (b * a) = + presentedPrincipalComponent k (@orderWeight n) s b * + presentedPrincipalComponent k (@orderWeight n) r a := by + simpa [Nat.add_comm] using + (presentedPrincipalComponent_mul_order k hb ha) + have htop : + presentedPrincipalComponent k (@orderWeight n) (r + s) + (Stafford.commutator a b) = 0 := by + change presentedPrincipalComponent k (@orderWeight n) (r + s) + (a * b - b * a) = 0 + rw [map_sub, + presentedPrincipalComponent_mul_order k ha hb, + hmulba] + exact sub_eq_zero.mpr (mul_comm _ _) + have hlower := + (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight n) _ hcomm).mp htop + cases hsum : r + s with + | zero => + have hr : r = 0 := by omega + have hs : s = 0 := by omega + subst r + subst s + simpa using hcomm + | succ t => + change a * b - b * a ∈ presentedWeightPiece k orderWeight t + simpa [presentedStrictLowerPiece, hsum] using hlower + +/-- Differential operators of order zero are multiplication operators and +therefore commute. -/ +theorem commutator_eq_zero_of_mem_orderPiece_zero + {n : ℕ} {a b : PresentedWeyl k n} + (ha : a ∈ orderPiece k n 0) (hb : b ∈ orderPiece k n 0) : + Stafford.commutator a b = 0 := by + have hab : a * b ∈ orderPiece k n 0 := by + simpa using (mul_mem_orderPiece k ha hb) + have hba : b * a ∈ orderPiece k n 0 := by + simpa using (mul_mem_orderPiece k hb ha) + have hcomm : Stafford.commutator a b ∈ orderPiece k n 0 := + Submodule.sub_mem _ hab hba + have htop : + presentedPrincipalComponent k (@orderWeight n) 0 + (Stafford.commutator a b) = 0 := by + change presentedPrincipalComponent k (@orderWeight n) 0 + (a * b - b * a) = 0 + rw [map_sub, + presentedPrincipalComponent_mul_order k ha hb, + presentedPrincipalComponent_mul_order k hb ha] + exact sub_eq_zero.mpr (mul_comm _ _) + have hlower := (presentedPrincipalComponent_eq_zero_iff_mem_strictLower + k (@orderWeight n) _ hcomm).mp htop + simpa [presentedStrictLowerPiece] using hlower + +@[simp] theorem poissonBracket_zero_left {n : ℕ} + (f : SymbolRing k n) : poissonBracket 0 f = 0 := by + simp [poissonBracket] + +@[simp] theorem poissonBracket_zero_right {n : ℕ} + (f : SymbolRing k n) : poissonBracket f 0 = 0 := by + simp [poissonBracket] + +theorem poissonBracket_add_left {n : ℕ} + (f g h : SymbolRing k n) : + poissonBracket (f + g) h = poissonBracket f h + poissonBracket g h := by + simp only [poissonBracket, map_add, add_mul] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + +theorem poissonBracket_add_right {n : ℕ} + (f g h : SymbolRing k n) : + poissonBracket f (g + h) = poissonBracket f g + poissonBracket f h := by + simp only [poissonBracket, map_add, mul_add] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + +theorem poissonBracket_smul_left {n : ℕ} + (c : k) (f g : SymbolRing k n) : + poissonBracket (c • f) g = c • poissonBracket f g := by + simp only [poissonBracket, Algebra.smul_def, MvPolynomial.pderiv_mul, + MvPolynomial.algebraMap_eq, MvPolynomial.pderiv_C, zero_mul, add_zero, + Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + ring + +theorem poissonBracket_smul_right {n : ℕ} + (c : k) (f g : SymbolRing k n) : + poissonBracket f (c • g) = c • poissonBracket f g := by + simp only [poissonBracket, Algebra.smul_def, MvPolynomial.pderiv_mul, + MvPolynomial.algebraMap_eq, MvPolynomial.pderiv_C, zero_mul, add_zero, + Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + ring + +/-- The one-contraction part of normal-ordered multiplication. It +differentiates the left monomial in momentum and the right monomial in the +matching coordinate. -/ +def pbwFirstContraction {n : ℕ} + (m q : PhaseVar n →₀ ℕ) : SymbolRing k n := + ∑ i : Fin n, + MvPolynomial.pderiv (.inr i) (MvPolynomial.monomial m 1) * + MvPolynomial.pderiv (.inl i) (MvPolynomial.monomial q 1) + +/-- Antisymmetrizing the first normal-ordering contraction is exactly the +negative Poisson bracket for the convention `[x,p] = -1`. -/ +theorem pbwFirstContraction_sub_swap_eq_neg_poisson {n : ℕ} + (m q : PhaseVar n →₀ ℕ) : + pbwFirstContraction k m q - pbwFirstContraction k q m = + -poissonBracket (MvPolynomial.monomial m 1) + (MvPolynomial.monomial q 1) := by + rw [pbwFirstContraction, pbwFirstContraction, poissonBracket, + ← Finset.sum_sub_distrib, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro i hi + ring + +theorem momentumExponent_eq_zero_of_orderWeight_eq_zero {n : ℕ} + (m : PhaseVar n →₀ ℕ) + (hm : monomialWeight (@orderWeight n) m = 0) (i : Fin n) : + m (.inr i) = 0 := by + by_contra hne + have himem : (.inr i : PhaseVar n) ∈ m.support := + Finsupp.mem_support_iff.mpr hne + have hle : + m (.inr i) * orderWeight (.inr i) ≤ + ∑ j ∈ m.support, m j * orderWeight j := + Finset.single_le_sum + (f := fun j => m j * orderWeight j) + (fun j _ => Nat.zero_le _) himem + have hle' : m (.inr i) ≤ monomialWeight (@orderWeight n) m := by + simpa [monomialWeight, Finsupp.sum, orderWeight, fibreWeight] using hle + omega + +theorem pbwFirstContraction_eq_zero_of_orderWeight_eq_zero {n : ℕ} + (m q : PhaseVar n →₀ ℕ) + (hm : monomialWeight (@orderWeight n) m = 0) : + pbwFirstContraction k m q = 0 := by + rw [pbwFirstContraction] + apply Finset.sum_eq_zero + intro i hi + rw [MvPolynomial.pderiv_monomial, + momentumExponent_eq_zero_of_orderWeight_eq_zero m hm i] + simp + +/-- A one-sided first-contraction formula for PBW products implies the exact +PBW commutator formula. Unlike a commutator restatement, the premise is the +specific local normal-ordering coefficient that the recursive PBW product API +must expose. -/ +theorem pbw_commutator_formula_of_firstContraction + {n : ℕ} + (hProduct : ∀ m q : PhaseVar n →₀ ℕ, + 0 < monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q → + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q - 1) + (presentedPBWBasis k n m * presentedPBWBasis k n q) = + pbwFirstContraction k m q) : + ∀ m q : PhaseVar n →₀ ℕ, + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q - 1) + (Stafford.commutator + (presentedPBWBasis k n m) (presentedPBWBasis k n q)) = + -poissonBracket (MvPolynomial.monomial m 1) + (MvPolynomial.monomial q 1) := by + intro m q + let R := monomialWeight (@orderWeight n) m + let S := monomialWeight (@orderWeight n) q + by_cases hpos : 0 < R + S + · change presentedPrincipalComponent k (@orderWeight n) (R + S - 1) + (presentedPBWBasis k n m * presentedPBWBasis k n q - + presentedPBWBasis k n q * presentedPBWBasis k n m) = _ + rw [map_sub, hProduct m q hpos] + have hpos' : 0 < S + R := by omega + rw [show R + S - 1 = S + R - 1 by omega, hProduct q m hpos'] + exact pbwFirstContraction_sub_swap_eq_neg_poisson k m q + · have hzero : R + S = 0 := by omega + have hR : R = 0 := by omega + have hS : S = 0 := by omega + have hmPiece : presentedPBWBasis k n m ∈ orderPiece k n 0 := by + exact (presentedPBWBasis_mem_weightPiece_iff k orderWeight 0 m).mpr + (by simpa [R] using hR.le) + have hqPiece : presentedPBWBasis k n q ∈ orderPiece k n 0 := by + exact (presentedPBWBasis_mem_weightPiece_iff k orderWeight 0 q).mpr + (by simpa [S] using hS.le) + rw [commutator_eq_zero_of_mem_orderPiece_zero k hmPiece hqPiece, map_zero] + rw [← pbwFirstContraction_sub_swap_eq_neg_poisson k m q, + pbwFirstContraction_eq_zero_of_orderWeight_eq_zero k m q hR, + pbwFirstContraction_eq_zero_of_orderWeight_eq_zero k q m hS, + sub_zero] + +/-- Bilinear PBW extension principle for the subprincipal commutator formula. +The hypothesis concerns every pair of actual PBW basis vectors at their exact +orders. The conclusion handles arbitrary finite PBW sums at arbitrary declared +filtration bounds, including vanishing leading components. -/ +theorem principalComponent_commutator_eq_neg_poisson_of_PBW + {n r s : ℕ} {a b : PresentedWeyl k n} + (hPBW : ∀ m q : PhaseVar n →₀ ℕ, + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q - 1) + (Stafford.commutator + (presentedPBWBasis k n m) (presentedPBWBasis k n q)) = + -poissonBracket (MvPolynomial.monomial m 1) + (MvPolynomial.monomial q 1)) + (ha : a ∈ orderPiece k n r) (hb : b ∈ orderPiece k n s) : + presentedPrincipalComponent k (@orderWeight n) (r + s - 1) + (Stafford.commutator a b) = + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r a) + (presentedPrincipalComponent k (@orderWeight n) s b) := by + rw [orderPiece, presentedWeightPiece_eq_span] at ha hb + apply Submodule.span_induction₂ + (p := fun a b _ _ => + presentedPrincipalComponent k (@orderWeight n) (r + s - 1) + (Stafford.commutator a b) = + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r a) + (presentedPrincipalComponent k (@orderWeight n) s b)) + (ha := ha) (hb := hb) + · intro x y hx hy + obtain ⟨m, hm, rfl⟩ := hx + obtain ⟨q, hq, rfl⟩ := hy + let R := monomialWeight (@orderWeight n) m + let S := monomialWeight (@orderWeight n) q + have hmPiece : presentedPBWBasis k n m ∈ orderPiece k n R := by + exact (presentedPBWBasis_mem_weightPiece_iff k orderWeight R m).mpr le_rfl + have hqPiece : presentedPBWBasis k n q ∈ orderPiece k n S := by + exact (presentedPBWBasis_mem_weightPiece_iff k orderWeight S q).mpr le_rfl + by_cases hR : R = r + · by_cases hS : S = s + · subst r + subst s + rw [presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp only [R, S, if_pos rfl] + exact hPBW m q + · have hSlt : S < s := lt_of_le_of_ne hq hS + rw [presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp only [R, S, hR, if_pos, hS, if_false, + poissonBracket_zero_right, neg_zero] + by_cases hzero : R + S = 0 + · have hR0 : R = 0 := by omega + have hS0 : S = 0 := by omega + rw [commutator_eq_zero_of_mem_orderPiece_zero k + (by simpa [hR0] using hmPiece) (by simpa [hS0] using hqPiece), + map_zero] + · have hmem := commutator_mem_orderPiece_pred k hmPiece hqPiece + apply presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight n) _ hmem + omega + · have hRlt : R < r := lt_of_le_of_ne hm hR + rw [presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp only [R, S, hR, if_false, poissonBracket_zero_left, neg_zero] + by_cases hzero : R + S = 0 + · have hR0 : R = 0 := by omega + have hS0 : S = 0 := by omega + rw [commutator_eq_zero_of_mem_orderPiece_zero k + (by simpa [hR0] using hmPiece) (by simpa [hS0] using hqPiece), + map_zero] + · have hmem := commutator_mem_orderPiece_pred k hmPiece hqPiece + apply presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight n) _ hmem + omega + · intro y hy + simp [Stafford.commutator] + · intro x hx + simp [Stafford.commutator] + · intro x y z hx hy hz hxy hyz + rw [show Stafford.commutator (x + y) z = + Stafford.commutator x z + Stafford.commutator y z by + change (x + y) * z - z * (x + y) = + (x * z - z * x) + (y * z - z * y) + noncomm_ring, + map_add, hxy, hyz, map_add, poissonBracket_add_left] + abel + · intro x y z hx hy hz hxy hxz + rw [show Stafford.commutator x (y + z) = + Stafford.commutator x y + Stafford.commutator x z by + change x * (y + z) - (y + z) * x = + (x * y - y * x) + (x * z - z * x) + noncomm_ring, + map_add, hxy, hxz, map_add, poissonBracket_add_right] + abel + · intro c x y hx hy hxy + rw [show Stafford.commutator (c • x) y = + c • Stafford.commutator x y by + change (c • x) * y - y * (c • x) = c • (x * y - y * x) + simp only [Algebra.smul_mul_assoc, + Algebra.mul_smul_comm, smul_sub], + map_smul, hxy, map_smul, poissonBracket_smul_left, smul_neg] + · intro c x y hx hy hxy + rw [show Stafford.commutator x (c • y) = + c • Stafford.commutator x y by + change x * (c • y) - (c • y) * x = c • (x * y - y * x) + simp only [Algebra.mul_smul_comm, + Algebra.smul_mul_assoc, smul_sub], + map_smul, hxy, map_smul, poissonBracket_smul_right, smul_neg] + +/-- Full arbitrary-sum consequence of the one-sided PBW first-contraction +formula. This packages both nontrivial bridges: antisymmetrization produces +the sign-correct Poisson bracket, and PBW bilinearity handles arbitrary +declared filtration bounds. -/ +theorem principalComponent_commutator_eq_neg_poisson_of_firstContraction + {n r s : ℕ} {a b : PresentedWeyl k n} + (hProduct : ∀ m q : PhaseVar n →₀ ℕ, + 0 < monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q → + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q - 1) + (presentedPBWBasis k n m * presentedPBWBasis k n q) = + pbwFirstContraction k m q) + (ha : a ∈ orderPiece k n r) (hb : b ∈ orderPiece k n s) : + presentedPrincipalComponent k (@orderWeight n) (r + s - 1) + (Stafford.commutator a b) = + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r a) + (presentedPrincipalComponent k (@orderWeight n) s b) := + principalComponent_commutator_eq_neg_poisson_of_PBW k + (pbw_commutator_formula_of_firstContraction k hProduct) ha hb + + +end + +end Stafford38.WeylFilteredCommutator diff --git a/LeanPool/Stafford38/Stafford38/Weyl/FilteredScalarLifting.lean b/LeanPool/Stafford38/Stafford38/Weyl/FilteredScalarLifting.lean new file mode 100644 index 0000000000..7ce4382448 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/FilteredScalarLifting.lean @@ -0,0 +1,538 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.PresentedScalarExtension +import Mathlib.RingTheory.Flat.Equalizer +import Mathlib.LinearAlgebra.TensorProduct.RightExactness +import Mathlib.LinearAlgebra.TensorProduct.Basis + +/-! +# Filtered scalar lifting for the presented Weyl algebra + +This file isolates the filtered linear-algebra step which is not supplied by +unfiltered PBW spanning. The point is that an element of the intersection of +two scalar-extended subspaces has a bounded source representative. The proof +uses the exact kernel statement for tensoring a quotient map; no target +initial generators and no strictness assertion are used. + +The small finite-dimensional example at the end records the cancellation +falsifier: an arbitrary high-degree representation need not be termwise +bounded, even though a bounded representation exists. +-/ + +namespace Stafford38.Weyl.FilteredScalarLifting + +open scoped TensorProduct + +open Stafford +open AlgebraicAnalysis +open Stafford38.Characteristic +open Stafford38.EulerSurjectivity +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW +open Stafford38.WeylUniversal +open Stafford38.WeylEulerResidue +open Stafford38.CharacteristicInitialIdeal +open Stafford38.CharacteristicFilteredQuotient +open Stafford38.Weyl.PresentedScalarExtension + +noncomputable section + + +universe u v + +variable {R S M : Type*} + +section RangeBaseChange + +variable [CommRing R] [CommRing S] [Algebra R S] +variable [AddCommGroup M] [Module R M] + +/- The image of the tensor extension of a subtype is exactly the submodule + base-change defined by `Submodule.baseChange`. -/ +theorem range_baseChange_subtype (p : Submodule R M) : + LinearMap.range (p.subtype.baseChange S) = p.baseChange S := + rfl + +end RangeBaseChange + +section FilteredIntersection + +variable [CommRing R] [CommRing S] [Algebra R S] +variable [AddCommGroup M] [Module R M] + +example [SMulCommClass R S S] : + Module S (S ⊗[R] M) := by infer_instance + +theorem baseChange_mono [SMulCommClass R S S] + {p q : Submodule R M} (hpq : p ≤ q) : + p.baseChange S ≤ q.baseChange S := by + rw [Submodule.baseChange_eq_span, Submodule.baseChange_eq_span] + apply Submodule.span_le.mpr + intro z hz + rcases hz with ⟨m, hm, rfl⟩ + exact Submodule.subset_span ⟨m, hpq hm, rfl⟩ + +/-! +Tensoring with a flat coefficient module preserves intersections of +submodules. The proof is deliberately phrased through the quotient map of +`q`: the reverse inclusion is a kernel statement, not an appeal to an +unfiltered spanning equality. +-/ +theorem baseChange_inf_eq [SMulCommClass R S S] + [Module.Flat R S] (p q : Submodule R M) : + p.baseChange S ⊓ q.baseChange S = (p ⊓ q).baseChange S := by + apply le_antisymm + · intro z hz + let f : p →ₗ[R] M ⧸ q := q.mkQ.comp p.subtype + have hqzero : + TensorProduct.AlgebraTensorModule.lTensor S S q.mkQ z = 0 := by + have hzq := hz.2 + rw [Submodule.baseChange_eq_span] at hzq + refine Submodule.span_induction ?_ ?_ ?_ ?_ hzq + · intro a ha + rcases ha with ⟨m, hm, rfl⟩ + have hmker : m ∈ LinearMap.ker q.mkQ := by + rw [Submodule.ker_mkQ q] + exact hm + change (1 : S) ⊗ₜ[R] q.mkQ m = 0 + rw [LinearMap.mem_ker.mp hmker] + simp + · simp + · intro a b _ _ ha hb + simpa only [map_add, ha, hb, add_zero] using rfl + · intro c a _ ha + simpa only [map_smul, ha, smul_zero] using rfl + have hpRange : z ∈ LinearMap.range (p.subtype.baseChange S) := by + rw [range_baseChange_subtype p] + exact hz.1 + obtain ⟨y, hy⟩ := hpRange + change TensorProduct.AlgebraTensorModule.lTensor S S p.subtype y = z at hy + have hyker : y ∈ LinearMap.ker + (TensorProduct.AlgebraTensorModule.lTensor S S f) := by + apply LinearMap.mem_ker.mpr + calc + TensorProduct.AlgebraTensorModule.lTensor S S f y = + TensorProduct.AlgebraTensorModule.lTensor S S q.mkQ + (TensorProduct.AlgebraTensorModule.lTensor S S p.subtype y) := by + rw [TensorProduct.AlgebraTensorModule.lTensor_comp] + rfl + _ = TensorProduct.AlgebraTensorModule.lTensor S S q.mkQ z := by + rw [hy] + _ = 0 := hqzero + have hyspan : y ∈ + LinearMap.range (TensorProduct.AlgebraTensorModule.lTensor S S + (LinearMap.ker f).subtype) := by + rw [← Module.Flat.ker_lTensor_eq (S := S) (M := S) f] + exact hyker + obtain ⟨v, hv⟩ := hyspan + change (LinearMap.ker f).subtype.baseChange S v = y at hv + let g : LinearMap.ker f →ₗ[R] ↥(p ⊓ q) := + { toFun := fun u => + ⟨(u : M), ⟨u.1.property, by + have hu : (u : M) ∈ LinearMap.ker q.mkQ := by + change q.mkQ (u : M) = 0 + exact u.property + exact Eq.mp (congrArg (fun r : Submodule R M => (u : M) ∈ r) + (Submodule.ker_mkQ q)) hu⟩⟩ + map_add' := by + intro u v + ext + simp + map_smul' := by + intro a u + ext + simp } + have hcomp : + p.subtype.comp (LinearMap.ker f).subtype = + (p ⊓ q).subtype.comp g := by + ext u + rfl + have hz' : z = (p ⊓ q).subtype.baseChange S + (g.baseChange S v) := by + calc + z = p.subtype.baseChange S y := hy.symm + _ = p.subtype.baseChange S + ((LinearMap.ker f).subtype.baseChange S v) := by rw [hv] + _ = (p.subtype.comp (LinearMap.ker f).subtype).baseChange S v := by + rw [LinearMap.baseChange_comp] + rfl + _ = ((p ⊓ q).subtype.comp g).baseChange S v := by rw [hcomp] + _ = (p ⊓ q).subtype.baseChange S (g.baseChange S v) := by + rw [LinearMap.baseChange_comp] + rfl + rw [hz'] + rw [← range_baseChange_subtype (p ⊓ q)] + exact ⟨g.baseChange S v, rfl⟩ + · intro z hz + exact ⟨baseChange_mono inf_le_left hz, + baseChange_mono inf_le_right hz⟩ + +end FilteredIntersection + +section WeylTensorBridge + +variable {k : Type u} {K : Type v} +variable [Field k] [Field K] [Algebra k K] + +/-! +The two PBW bases identify the ordinary tensor base-change with the target +presented Weyl algebra. This is the concrete bridge that turns the abstract +intersection theorem above into a bounded PBW decomposition. +-/ +def pbwTensorEquiv (n : Nat) : + (K ⊗[k] PresentedWeyl k n) ≃ₗ[K] PresentedWeyl K n := + (presentedPBWBasis k n).baseChange K |>.equiv + (presentedPBWBasis K n) (Equiv.refl (PhaseVar n →₀ ℕ)) + +theorem pbwTensorEquiv_tmul_one (n : Nat) (z : PresentedWeyl k n) : + pbwTensorEquiv (k := k) (K := K) n (1 ⊗ₜ[k] z) = + presentedWeylScalarExtension (k := k) (K := K) n z := by + let f : PresentedWeyl k n →ₗ[k] PresentedWeyl K n := + (pbwTensorEquiv (k := k) (K := K) n).toLinearMap.restrictScalars k |>.comp + (TensorProduct.mk k K (PresentedWeyl k n) 1) + have hf : f = + (presentedWeylScalarExtension (k := k) (K := K) n).toLinearMap := by + apply Module.Basis.ext (presentedPBWBasis k n) + intro m + dsimp [f] + change pbwTensorEquiv (k := k) (K := K) n + (1 ⊗ₜ[k] presentedPBWBasis k n m) = + presentedWeylScalarExtension (k := k) (K := K) n + (presentedPBWBasis k n m) + rw [← Module.Basis.baseChange_apply, pbwTensorEquiv, Module.Basis.equiv_apply, + presentedWeylScalarExtension_basis] + rfl + exact DFunLike.congr_fun hf z + +theorem pbwTensorEquiv_map_orderPiece (n L : Nat) : + Submodule.map (pbwTensorEquiv (k := k) (K := K) n).toLinearMap + ((orderPiece k n L).baseChange K) = + orderPiece K n L := by + rw [orderPiece, presentedWeightPiece_eq_span, + Submodule.baseChange_span, orderPiece, + presentedWeightPiece_eq_span, Submodule.map_span] + congr 1 + ext z + constructor + · rintro ⟨y, ⟨a, ha, rfl⟩, rfl⟩ + rcases ha with ⟨m, hm, rfl⟩ + refine ⟨m, hm, ?_⟩ + calc + (pbwTensorEquiv (k := k) (K := K) n) + ((TensorProduct.mk k K (PresentedWeyl k n) 1) + (presentedPBWBasis k n m)) = + pbwTensorEquiv (k := k) (K := K) n + (1 ⊗ₜ[k] presentedPBWBasis k n m) := rfl + _ = presentedWeylScalarExtension (k := k) (K := K) n + (presentedPBWBasis k n m) := + pbwTensorEquiv_tmul_one (k := k) (K := K) n + (presentedPBWBasis k n m) + _ = presentedPBWBasis K n m := + presentedWeylScalarExtension_basis (k := k) (K := K) n m + · rintro ⟨m, hm, rfl⟩ + refine ⟨1 ⊗ₜ[k] presentedPBWBasis k n m, + ⟨presentedPBWBasis k n m, ⟨m, hm, rfl⟩, rfl⟩, ?_⟩ + calc + pbwTensorEquiv (k := k) (K := K) n + (1 ⊗ₜ[k] presentedPBWBasis k n m) = + presentedWeylScalarExtension (k := k) (K := K) n + (presentedPBWBasis k n m) := + pbwTensorEquiv_tmul_one (k := k) (K := K) n + (presentedPBWBasis k n m) + _ = presentedPBWBasis K n m := + presentedWeylScalarExtension_basis (k := k) (K := K) n m + +theorem pbwTensorEquiv_map_baseChange (n : Nat) + (J : Submodule k (PresentedWeyl k n)) : + Submodule.map (pbwTensorEquiv (k := k) (K := K) n).toLinearMap + (J.baseChange K) = + Submodule.span K + (presentedWeylScalarExtension (k := k) (K := K) n '' + (J : Set (PresentedWeyl k n))) := by + rw [Submodule.baseChange_eq_span, Submodule.map_span] + congr 1 + ext z + constructor + · rintro ⟨y, ⟨m, hm, rfl⟩, rfl⟩ + refine ⟨m, hm, ?_⟩ + exact (pbwTensorEquiv_tmul_one (k := k) (K := K) n m).symm + · rintro ⟨m, hm, rfl⟩ + refine ⟨1 ⊗ₜ[k] m, ⟨m, hm, rfl⟩, ?_⟩ + exact pbwTensorEquiv_tmul_one (k := k) (K := K) n m + +theorem pbwTensorEquiv_map_rightIdeal (n : Nat) + (I : RightIdeal (PresentedWeyl k n)) : + Submodule.map (pbwTensorEquiv (k := k) (K := K) n).toLinearMap + ((rightIdealKSubmodule k I).baseChange K) = + scalarImageRightIdealSpan (k := k) (K := K) n I := by + rw [Submodule.baseChange_eq_span, Submodule.map_span, + scalarImageRightIdealSpan] + congr 1 + ext z + constructor + · rintro ⟨y, ⟨m, hm, rfl⟩, rfl⟩ + refine ⟨m, hm, ?_⟩ + exact (pbwTensorEquiv_tmul_one (k := k) (K := K) n m).symm + · rintro ⟨m, hm, rfl⟩ + refine ⟨1 ⊗ₜ[k] m, ⟨m, hm, rfl⟩, ?_⟩ + exact pbwTensorEquiv_tmul_one (k := k) (K := K) n m + +theorem pbwTensorEquiv_map_canonicalRightIdeal + (n N : Nat) (d : PresentedWeyl k (n + 1)) : + Submodule.map (pbwTensorEquiv (k := k) (K := K) (n + 1)).toLinearMap + ((rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N)).baseChange K) = + rightIdealKSubmodule K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) := by + rw [pbwTensorEquiv_map_rightIdeal] + apply le_antisymm + · apply Submodule.span_le.mpr + rintro z ⟨a, ha, rfl⟩ + exact presentedWeylScalarExtension_mem_canonicalRightIdeal + (k := k) (K := K) n N ha + · intro z hz + exact target_canonicalRightIdeal_le_scalarImageRightIdealSpan + (k := k) (K := K) n N d z hz + +theorem pbwTensorEquiv_map_canonicalRightIdeal_inf_orderPiece + (n N L : Nat) (d : PresentedWeyl k (n + 1)) : + Submodule.map (pbwTensorEquiv (k := k) (K := K) (n + 1)).toLinearMap + ((rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L).baseChange K) = + rightIdealKSubmodule K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) ⊓ + orderPiece K (n + 1) L := by + rw [← baseChange_inf_eq + (R := k) (S := K) + (rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N)) + (orderPiece k (n + 1) L)] + rw [Submodule.map_inf + (pbwTensorEquiv (k := k) (K := K) (n + 1)).toLinearMap + (pbwTensorEquiv (k := k) (K := K) (n + 1)).injective, + pbwTensorEquiv_map_canonicalRightIdeal, + pbwTensorEquiv_map_orderPiece] + +theorem target_canonicalRightIdeal_orderPiece_mem_source_span + (n N L : Nat) (d : PresentedWeyl k (n + 1)) + {z : PresentedWeyl K (n + 1)} + (hzIdeal : z ∈ canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) + (hzOrder : z ∈ orderPiece K (n + 1) L) : + z ∈ Submodule.span K + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) '' + ((rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L) : + Set (PresentedWeyl k (n + 1)))) := by + let J : Submodule k (PresentedWeyl k (n + 1)) := + rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L + change z ∈ Submodule.span K + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) '' + (J : Set (PresentedWeyl k (n + 1)))) + rw [← pbwTensorEquiv_map_baseChange (k := k) (K := K) (n + 1) J] + rw [pbwTensorEquiv_map_canonicalRightIdeal_inf_orderPiece] + exact ⟨hzIdeal, hzOrder⟩ + +theorem target_canonicalRightIdeal_orderPiece_exists_fin_decomposition + (n N L : Nat) (d : PresentedWeyl k (n + 1)) + {z : PresentedWeyl K (n + 1)} + (hzIdeal : z ∈ canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) + (hzOrder : z ∈ orderPiece K (n + 1) L) : + ∃ (r : Nat) (c : Fin r → K) + (w : Fin r → + ↥(rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L)), + ∑ i, c i • + presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (w i : PresentedWeyl k (n + 1)) = z := by + classical + have hzSpan := target_canonicalRightIdeal_orderPiece_mem_source_span + (k := k) (K := K) n N L d hzIdeal hzOrder + rcases (Submodule.mem_span_set').mp hzSpan with ⟨r, c, g, hg⟩ + let J : Submodule k (PresentedWeyl k (n + 1)) := + rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L + let w : Fin r → J := fun i => + ⟨Classical.choose (g i).property, + (Classical.choose_spec (g i).property).1⟩ + have hw (i : Fin r) : + presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (w i : PresentedWeyl k (n + 1)) = (g i : PresentedWeyl K (n + 1)) := + (Classical.choose_spec (g i).property).2 + refine ⟨r, c, w, ?_⟩ + calc + ∑ i, c i • presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (w i : PresentedWeyl k (n + 1)) = + ∑ i, c i • (g i : PresentedWeyl K (n + 1)) := by + apply Finset.sum_congr rfl + intro i hi + rw [hw i] + _ = z := hg + +theorem target_orderInitialIdeal_le_map_source_orderInitialIdeal + (n N : Nat) (d : PresentedWeyl k (n + 1)) : + orderInitialIdeal K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) ≤ + (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (symbolScalarExtension (k := k) (K := K) (n + 1)).toRingHom := by + apply Ideal.span_le.mpr + intro P hP + rcases hP with ⟨L, z, hzOrder, hzIdeal, rfl⟩ + let I : RightIdeal (PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + let IK : RightIdeal (PresentedWeyl K (n + 1)) := + canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N + let J : Submodule k (PresentedWeyl k (n + 1)) := + rightIdealKSubmodule k I ⊓ orderPiece k (n + 1) L + have hzMap : z ∈ Submodule.map + (pbwTensorEquiv (k := k) (K := K) (n + 1)).toLinearMap + (J.baseChange K) := by + change z ∈ Submodule.map + (pbwTensorEquiv (k := k) (K := K) (n + 1)).toLinearMap + ((rightIdealKSubmodule k + (canonicalRightIdeal (presentedCoordinate k n) d N) ⊓ + orderPiece k (n + 1) L).baseChange K) + rw [pbwTensorEquiv_map_canonicalRightIdeal_inf_orderPiece] + exact ⟨hzIdeal, hzOrder⟩ + have hzSpan : z ∈ Submodule.span K + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) '' + (J : Set (PresentedWeyl k (n + 1)))) := by + rw [← pbwTensorEquiv_map_baseChange (k := k) (K := K) (n + 1) J] + exact hzMap + let M : Ideal (SymbolRing K (n + 1)) := + (orderInitialIdeal k I).map + (symbolScalarExtension (k := k) (K := K) (n + 1)).toRingHom + refine Submodule.span_induction ?_ ?_ ?_ ?_ hzSpan + · intro a ha + rcases ha with ⟨w, hw, rfl⟩ + have hwOrder : w ∈ orderPiece k (n + 1) L := hw.2 + have hwIdeal : w ∈ I := hw.1 + have hsource : presentedPrincipalComponent k orderWeight L w ∈ + orderInitialIdeal k I := by + exact orderPrincipalComponent_mem_initialIdeal k I w hwOrder hwIdeal + have hmap : symbolScalarExtension (k := k) (K := K) (n + 1) + (presentedPrincipalComponent k orderWeight L w) ∈ M := by + exact Ideal.mem_map_of_mem _ hsource + change presentedPrincipalComponent K orderWeight L + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) w) ∈ M + rw [← presentedWeylScalarExtension_principalComponent + (k := k) (K := K) (n + 1) orderWeight L w] + exact hmap + · simpa only [map_zero, SetLike.mem_coe] using M.zero_mem + · intro a b _ _ ha hb + simpa only [map_add, SetLike.mem_coe] using + M.add_mem (SetLike.mem_coe.mp ha) (SetLike.mem_coe.mp hb) + · intro c a _ ha + rw [map_smul, Algebra.smul_def] + exact Ideal.mul_mem_left M _ (SetLike.mem_coe.mp ha) + +/-- Flat filtered lifting discharges the exact algebraic-closure descent +contract isolated by `PresentedScalarExtension`. -/ +theorem filteredInitialLifting : FilteredInitialLifting.{u} := by + intro k _ _ n N d + exact target_orderInitialIdeal_le_map_source_orderInitialIdeal + (k := k) (K := AlgebraicClosure k) n N d + +/-- The scalar-extension input consumed by the terminal Stafford reduction is +therefore unconditional. -/ +theorem canonicalSupportDescent : + CanonicalSupportVanishingReduction.CanonicalSupportDescent.{u} := + canonicalSupportDescent_of_filteredInitialLifting filteredInitialLifting + +section CancellationFalsifier + +/-! +An unfiltered representation cannot be truncated term by term. Here the +low piece is the first coordinate axis, while the source span is all of +`ℚ × ℚ`. The displayed representation of `(1, 0)` has two summands outside +the low piece whose second coordinates cancel. The preceding flat +intersection theorem is the surviving filtration-on-span replacement. +-/ +theorem cancellation_falsifier : + let F : Submodule ℚ (ℚ × ℚ) := + Submodule.span ℚ ({(1, 0)} : Set (ℚ × ℚ)) + let I : Submodule ℚ (ℚ × ℚ) := + Submodule.span ℚ ({(1, 1), (0, 1)} : Set (ℚ × ℚ)) + let z : ℚ × ℚ := (1, 0) + z ∈ I ⊓ F ∧ + (1, 1) ∉ F ∧ + (0, 1) ∉ F ∧ + ((1, 1) : ℚ × ℚ) - ((0, 1) : ℚ × ℚ) = z := by + dsimp + let F : Submodule ℚ (ℚ × ℚ) := + Submodule.span ℚ ({(1, 0)} : Set (ℚ × ℚ)) + let I : Submodule ℚ (ℚ × ℚ) := + Submodule.span ℚ ({(1, 1), (0, 1)} : Set (ℚ × ℚ)) + have hzF : ((1, 0) : ℚ × ℚ) ∈ F := by + apply Submodule.subset_span + simp [F] + have huI : ((1, 1) : ℚ × ℚ) ∈ I := by + apply Submodule.subset_span + simp [I] + have hvI : ((0, 1) : ℚ × ℚ) ∈ I := by + apply Submodule.subset_span + simp [I] + have hzI : ((1, 0) : ℚ × ℚ) ∈ I := by + have hdiff := I.sub_mem huI hvI + have heq : ((1, 1) : ℚ × ℚ) - ((0, 1) : ℚ × ℚ) = (1, 0) := by + ext <;> norm_num + rw [← heq] + exact hdiff + have huF : ((1, 1) : ℚ × ℚ) ∉ F := by + intro hu + change ((1, 1) : ℚ × ℚ) ∈ + Submodule.span ℚ ({(1, 0)} : Set (ℚ × ℚ)) at hu + rw [Submodule.mem_span_singleton] at hu + rcases hu with ⟨c, hc⟩ + have := congrArg Prod.snd hc + simp at this + have hvF : ((0, 1) : ℚ × ℚ) ∉ F := by + intro hv + change ((0, 1) : ℚ × ℚ) ∈ + Submodule.span ℚ ({(1, 0)} : Set (ℚ × ℚ)) at hv + rw [Submodule.mem_span_singleton] at hv + rcases hv with ⟨c, hc⟩ + have := congrArg Prod.snd hc + simp at this + refine ⟨⟨hzI, hzF⟩, huF, hvF, ?_⟩ + ext <;> norm_num + +end CancellationFalsifier + +end WeylTensorBridge + +/-- After scalar descent, the terminal theorem has exactly the three genuine +mathematical inputs: an order-zero unit coordinate predecessor, post-extension +symbol control, and the asymptotic Laurent conormal producer. -/ +theorem universalStatement_of_three_inputs + (hunit : + CanonicalSupportVanishingReduction.CanonicalStrictUnitCoordinatePreimage.{u}) + (hcontrol : + CanonicalSupportVanishingReduction.CanonicalLaurentSymbolControl.{u}) + (hasymptotic : + CanonicalSupportVanishingReduction.CanonicalAsymptoticLaurentProducer.{u}) : + Stafford38.UniversalStatement.{u} := + CanonicalSupportVanishingReduction.universalStatement_of_four_inputs + hunit hcontrol hasymptotic canonicalSupportDescent + +end +end Stafford38.Weyl.FilteredScalarLifting diff --git a/LeanPool/Stafford38/Stafford38/Weyl/Filtration.lean b/LeanPool/Stafford38/Stafford38/Weyl/Filtration.lean new file mode 100644 index 0000000000..4b4968f28f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/Filtration.lean @@ -0,0 +1,599 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.PBW + +/-! +# Weighted PBW truncations + +The ordered PBW basis gives intrinsic finite-degree subspaces of the presented +Weyl algebra. This file constructs the truncations for an arbitrary weight on +the named generators, proves their coefficient characterization, monotonicity, +exhaustiveness, and basis-monomial membership, and specializes them to the +Bernstein and order weights. Exact normal ordering then proves multiplicative +closure. Leading symbols and the associated graded algebra remain downstream. +-/ + +namespace Stafford38.WeylFiltration + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBW + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Weighted degree of a commutative phase-space monomial. -/ +def monomialWeight {n : ℕ} (w : PhaseVar n → ℕ) + (m : PhaseVar n →₀ ℕ) : ℕ := + m.sum fun i e => e * w i + +/-- Extend an old exponent vector by exponents for the newest coordinate and +momentum. -/ +def extendPhaseExponent (n a p : ℕ) (m : PhaseVar n →₀ ℕ) : + PhaseVar (n + 1) →₀ ℕ := + Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a + + Finsupp.mapDomain oldIndex m + +theorem monomialWeight_mono {n : ℕ} {w₁ w₂ : PhaseVar n → ℕ} + (h : ∀ i, w₁ i ≤ w₂ i) (m : PhaseVar n →₀ ℕ) : + monomialWeight w₁ m ≤ monomialWeight w₂ m := by + apply Finsupp.sum_le_sum + intro i _ + exact Nat.mul_le_mul_left _ (h i) + +/-- Symbols supported on monomials of weighted degree at most `N`. -/ +def symbolWeightPiece {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + Submodule k (SymbolRing k n) where + carrier := {f | ∀ m, MvPolynomial.coeff m f ≠ 0 → monomialWeight w m ≤ N} + zero_mem' m hm := by simp at hm + add_mem' {f g} hf hg m hm := by + by_cases hfm : MvPolynomial.coeff m f = 0 + · apply hg m + simpa [MvPolynomial.coeff_add, hfm] using hm + · exact hf m hfm + smul_mem' c f hf m hm := by + apply hf m + intro hfm + apply hm + simp [MvPolynomial.coeff_smul, hfm] + +@[simp] theorem mem_symbolWeightPiece {n : ℕ} (w : PhaseVar n → ℕ) + (N : ℕ) (f : SymbolRing k n) : + f ∈ symbolWeightPiece k w N ↔ + ∀ m, MvPolynomial.coeff m f ≠ 0 → monomialWeight w m ≤ N := + Iff.rfl + +theorem symbolWeightPiece_mono {n : ℕ} (w : PhaseVar n → ℕ) + {N M : ℕ} (hNM : N ≤ M) : + symbolWeightPiece k w N ≤ symbolWeightPiece k w M := by + intro f hf m hm + exact (hf m hm).trans hNM + +theorem symbolWeightPiece_antitone_weight {n : ℕ} + {w₁ w₂ : PhaseVar n → ℕ} (h : ∀ i, w₁ i ≤ w₂ i) (N : ℕ) : + symbolWeightPiece k w₂ N ≤ symbolWeightPiece k w₁ N := by + intro f hf m hm + exact (monomialWeight_mono h m).trans (hf m hm) + +@[simp] theorem monomial_mem_symbolWeightPiece_iff {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) (m : PhaseVar n →₀ ℕ) : + MvPolynomial.monomial m (1 : k) ∈ symbolWeightPiece k w N ↔ + monomialWeight w m ≤ N := by + constructor + · intro h + apply h m + simp [MvPolynomial.coeff_monomial] + · intro hm q hq + simp only [MvPolynomial.coeff_monomial] at hq + split at hq + · next h => simpa [h] using hm + · contradiction + +/-- The sum of the weights of all supported monomials is a simple exhaustive +bound. It is not intended to be the minimal weighted degree. -/ +def symbolSupportWeightBound {n : ℕ} (w : PhaseVar n → ℕ) + (f : SymbolRing k n) : ℕ := + f.support.sum (monomialWeight w) + +theorem mem_symbolWeightPiece_supportBound {n : ℕ} + (w : PhaseVar n → ℕ) (f : SymbolRing k n) : + f ∈ symbolWeightPiece k w (symbolSupportWeightBound k w f) := by + intro m hm + apply Finset.single_le_sum (fun _ _ => Nat.zero_le _) + exact MvPolynomial.mem_support_iff.mpr hm + +/-- Pull a weighted symbol truncation back through checked Weyl normal-form +coordinates. -/ +def presentedWeightPiece {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + Submodule k (PresentedWeyl k n) := + (symbolWeightPiece k w N).comap + (presentedNormalFormLinearEquiv k n).toLinearMap + +@[simp] theorem mem_presentedWeightPiece {n : ℕ} (w : PhaseVar n → ℕ) + (N : ℕ) (a : PresentedWeyl k n) : + a ∈ presentedWeightPiece k w N ↔ + ∀ m, MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n a) ≠ 0 → + monomialWeight w m ≤ N := + Iff.rfl + +theorem presentedWeightPiece_mono {n : ℕ} (w : PhaseVar n → ℕ) + {N M : ℕ} (hNM : N ≤ M) : + presentedWeightPiece k w N ≤ presentedWeightPiece k w M := + Submodule.comap_mono (symbolWeightPiece_mono k w hNM) + +theorem presentedWeightPiece_antitone_weight {n : ℕ} + {w₁ w₂ : PhaseVar n → ℕ} (h : ∀ i, w₁ i ≤ w₂ i) (N : ℕ) : + presentedWeightPiece k w₂ N ≤ presentedWeightPiece k w₁ N := + Submodule.comap_mono (symbolWeightPiece_antitone_weight k h N) + +theorem presentedNormalFormLinearEquiv_basis {n : ℕ} + (m : PhaseVar n →₀ ℕ) : + presentedNormalFormLinearEquiv k n (presentedPBWBasis k n m) = + MvPolynomial.monomial m 1 := by + rw [presentedPBWBasis, presentedNormalFormBasis_apply, + LinearEquiv.apply_symm_apply] + +theorem presentedPBWBasis_mem_weightPiece_iff {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) (m : PhaseVar n →₀ ℕ) : + presentedPBWBasis k n m ∈ presentedWeightPiece k w N ↔ + monomialWeight w m ≤ N := by + rw [mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_basis] + exact monomial_mem_symbolWeightPiece_iff k w N m + +/-- The ordered PBW basis vectors whose weights are bounded by `N`. -/ +def presentedWeightBasisSet {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + Set (PresentedWeyl k n) := + {a | ∃ m : PhaseVar n →₀ ℕ, + monomialWeight w m ≤ N ∧ a = presentedPBWBasis k n m} + +/-- The coefficient-support definition of a weighted truncation agrees with +the span of exactly the bounded ordered PBW basis vectors. -/ +theorem presentedWeightPiece_eq_span {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + presentedWeightPiece k w N = + Submodule.span k (presentedWeightBasisSet k w N) := by + apply le_antisymm + · intro a ha + let f := presentedNormalFormLinearEquiv k n a + have hreconstruct : + a = ∑ m ∈ f.support, + MvPolynomial.coeff m f • presentedPBWBasis k n m := by + apply (presentedNormalFormLinearEquiv k n).injective + simp only [map_sum, map_smul, + presentedNormalFormLinearEquiv_basis] + change f = _ + calc + f = ∑ m ∈ f.support, + MvPolynomial.monomial m (MvPolynomial.coeff m f) := + MvPolynomial.as_sum f + _ = _ := by + apply Finset.sum_congr rfl + intro m hm + rw [MvPolynomial.smul_monomial] + simp + rw [hreconstruct] + apply Submodule.sum_mem + intro m hm + apply Submodule.smul_mem + apply Submodule.subset_span + exact ⟨m, ha m (MvPolynomial.mem_support_iff.mp hm), rfl⟩ + · apply Submodule.span_le.mpr + intro a ha + obtain ⟨m, hm, rfl⟩ := ha + exact (presentedPBWBasis_mem_weightPiece_iff k w N m).mpr hm + +/-- Normal form of a bounded old basis vector followed by the newest pair. -/ +theorem presentedCoefficientOrdered_basis_normal (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) : + presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p (presentedPBWBasis k n m)) = + MvPolynomial.monomial (extendPhaseExponent n a p m) 1 := by + rw [presentedNormalFormLinearEquiv_previous_ordered, + presentedNormalFormLinearEquiv_basis, + MvPolynomial.rename_monomial, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.monomial_mul, MvPolynomial.monomial_mul] + simp [extendPhaseExponent] + +/-- Appending a fixed newest-pair monomial is scalar-linear in the old +coefficient. -/ +def presentedCoefficientOrderedLinear (n a p : ℕ) : + PresentedWeyl k n →ₗ[k] PresentedWeyl k (n + 1) where + toFun z := presentedCoefficientOrdered k n a p z + map_add' z w := by + simp [presentedCoefficientOrdered, map_add, add_mul] + map_smul' c z := by + simp [presentedCoefficientOrdered, map_smul, Algebra.smul_mul_assoc] + +theorem exists_mem_presentedWeightPiece {n : ℕ} (w : PhaseVar n → ℕ) + (a : PresentedWeyl k n) : + ∃ N, a ∈ presentedWeightPiece k w N := by + let f := presentedNormalFormLinearEquiv k n a + exact ⟨symbolSupportWeightBound k w f, + mem_symbolWeightPiece_supportBound k w f⟩ + +/-- Every named generator has Bernstein weight one. -/ +def bernsteinWeight {n : ℕ} (_ : PhaseVar n) : ℕ := 1 + +/-- Coordinates have order weight zero and momenta have order weight one. -/ +def orderWeight {n : ℕ} : PhaseVar n → ℕ := fibreWeight + +theorem monomialWeight_extend_bernstein (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) : + monomialWeight (@bernsteinWeight n) m + a + p = + monomialWeight (@bernsteinWeight (n + 1)) + (extendPhaseExponent n a p m) := by + simp only [extendPhaseExponent, monomialWeight] + rw [Finsupp.sum_add_index, Finsupp.sum_add_index, + Finsupp.sum_single_index, Finsupp.sum_single_index, + Finsupp.sum_mapDomain_index] + · simp [bernsteinWeight, add_comm, add_left_comm, add_assoc] + all_goals simp [bernsteinWeight, add_mul] + +theorem monomialWeight_extend_order (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) : + monomialWeight (@orderWeight n) m + p = + monomialWeight (@orderWeight (n + 1)) + (extendPhaseExponent n a p m) := by + simp only [extendPhaseExponent, monomialWeight] + rw [Finsupp.sum_add_index, Finsupp.sum_add_index, + Finsupp.sum_single_index, Finsupp.sum_single_index, + Finsupp.sum_mapDomain_index] + · simp only [orderWeight, fibreWeight, Nat.mul_one, Nat.mul_zero, add_zero] + rw [add_comm] + congr 1 + apply Finsupp.sum_congr + intro i hi + cases i <;> simp [orderWeight, fibreWeight, oldIndex] + all_goals simp [orderWeight, fibreWeight, oldIndex, add_mul] + +theorem phaseExponent_succ_eq_extend (n : ℕ) + (a p : Fin (n + 1) → ℕ) : + phaseExponent a p = + extendPhaseExponent n (a 0) (p 0) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) := + phaseExponent_succ n a p + +theorem monomialWeight_phaseExponent_succ_bernstein + (n : ℕ) (a p : Fin (n + 1) → ℕ) : + monomialWeight (@bernsteinWeight (n + 1)) (phaseExponent a p) = + monomialWeight (@bernsteinWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + + a 0 + p 0 := by + rw [phaseExponent_succ_eq_extend, + ← monomialWeight_extend_bernstein] + +theorem monomialWeight_phaseExponent_succ_order + (n : ℕ) (a p : Fin (n + 1) → ℕ) : + monomialWeight (@orderWeight (n + 1)) (phaseExponent a p) = + monomialWeight (@orderWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + p 0 := by + rw [phaseExponent_succ_eq_extend, + ← monomialWeight_extend_order] + +/-- Bernstein truncation of the presented Weyl algebra. -/ +def bernsteinPiece (n N : ℕ) : Submodule k (PresentedWeyl k n) := + presentedWeightPiece k bernsteinWeight N + +/-- Differential-order truncation of the presented Weyl algebra. -/ +abbrev orderPiece (n N : ℕ) : Submodule k (PresentedWeyl k n) := + presentedWeightPiece k (@orderWeight n) N + +/-- Appending a normal-ordered newest pair increases Bernstein degree by at +most the sum of the two new exponents. -/ +theorem presentedCoefficientOrdered_mem_bernsteinPiece + (n N a p : ℕ) (z : PresentedWeyl k n) + (hz : z ∈ bernsteinPiece k n N) : + presentedCoefficientOrdered k n a p z ∈ + bernsteinPiece k (n + 1) (N + a + p) := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at hz + induction hz using Submodule.span_induction with + | mem z hz => + obtain ⟨m, hm, rfl⟩ := hz + rw [bernsteinPiece, mem_presentedWeightPiece, + presentedCoefficientOrdered_basis_normal] + intro q hq + simp only [MvPolynomial.coeff_monomial] at hq + split at hq + · next h => + subst q + rw [← monomialWeight_extend_bernstein] + omega + · contradiction + | zero => + change presentedCoefficientOrderedLinear k n a p 0 ∈ _ + rw [map_zero] + exact Submodule.zero_mem _ + | add x y hx hy ihx ihy => + change presentedCoefficientOrderedLinear k n a p (x + y) ∈ _ + rw [map_add] + exact Submodule.add_mem _ ihx ihy + | smul c x hx ih => + change presentedCoefficientOrderedLinear k n a p (c • x) ∈ _ + rw [map_smul] + exact Submodule.smul_mem _ c ih + +/-- Appending a normal-ordered newest pair increases differential order by at +most the new momentum exponent; coordinate powers have order zero. -/ +theorem presentedCoefficientOrdered_mem_orderPiece + (n N a p : ℕ) (z : PresentedWeyl k n) + (hz : z ∈ orderPiece k n N) : + presentedCoefficientOrdered k n a p z ∈ + orderPiece k (n + 1) (N + p) := by + rw [orderPiece, presentedWeightPiece_eq_span] at hz + induction hz using Submodule.span_induction with + | mem z hz => + obtain ⟨m, hm, rfl⟩ := hz + rw [orderPiece, mem_presentedWeightPiece, + presentedCoefficientOrdered_basis_normal] + intro q hq + simp only [MvPolynomial.coeff_monomial] at hq + split at hq + · next h => + subst q + rw [← monomialWeight_extend_order] + omega + · contradiction + | zero => + change presentedCoefficientOrderedLinear k n a p 0 ∈ _ + rw [map_zero] + exact Submodule.zero_mem _ + | add x y hx hy ihx ihy => + change presentedCoefficientOrderedLinear k n a p (x + y) ∈ _ + rw [map_add] + exact Submodule.add_mem _ ihx ihy + | smul c x hx ih => + change presentedCoefficientOrderedLinear k n a p (c • x) ∈ _ + rw [map_smul] + exact Submodule.smul_mem _ c ih + +/-- Products of ordered PBW monomials satisfy the Bernstein degree bound. -/ +theorem presentedOrderedMonomial_mul_mem_bernsteinPiece : + ∀ (n : ℕ) (a p c q : Fin n → ℕ), + presentedOrderedMonomial k n a p * presentedOrderedMonomial k n c q ∈ + bernsteinPiece k n + (monomialWeight (@bernsteinWeight n) (phaseExponent a p) + + monomialWeight (@bernsteinWeight n) (phaseExponent c q)) := by + intro n + induction n with + | zero => + intro a p c q + have hap : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + have hcq : phaseExponent c q = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hap, hcq] + simp only [monomialWeight, Finsupp.sum_zero_index, zero_add] + simp only [presentedOrderedMonomial, one_mul] + change (1 : PresentedWeyl k 0) ∈ bernsteinPiece k 0 0 + rw [bernsteinPiece, mem_presentedWeightPiece] + intro m hm + have hone : + presentedNormalFormLinearEquiv k 0 (1 : PresentedWeyl k 0) = 1 := + presentedNormalFormLinearEquiv_one k 0 + rw [hone] at hm + have hm0 : m = 0 := by + symm + simpa [MvPolynomial.coeff_one] using hm + subst m + simp [monomialWeight] + | succ n ih => + intro a p c q + change + presentedCoefficientOrdered k n (a 0) (p 0) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoefficientOrdered k n (c 0) (q 0) + (presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) ∈ _ + rw [presentedCoefficientOrdered_mul] + apply Submodule.sum_mem + intro i hi + have hib : i ≤ p 0 := by + have := Finset.mem_range.mp hi + omega + by_cases hic : i ≤ c 0 + · simp only [if_pos hic] + apply Submodule.smul_mem + have hterm := presentedCoefficientOrdered_mem_bernsteinPiece k + n + (monomialWeight (@bernsteinWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + + monomialWeight (@bernsteinWeight n) + (phaseExponent (fun i => c i.succ) (fun i => q i.succ))) + (a 0 + c 0 - i) (p 0 + q 0 - i) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ) * + presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) + (ih (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ)) + apply presentedWeightPiece_mono k bernsteinWeight _ hterm + rw [monomialWeight_phaseExponent_succ_bernstein, + monomialWeight_phaseExponent_succ_bernstein] + omega + · simp [hic] + +/-- Products of ordered PBW monomials satisfy the differential-order bound. -/ +theorem presentedOrderedMonomial_mul_mem_orderPiece : + ∀ (n : ℕ) (a p c q : Fin n → ℕ), + presentedOrderedMonomial k n a p * presentedOrderedMonomial k n c q ∈ + orderPiece k n + (monomialWeight (@orderWeight n) (phaseExponent a p) + + monomialWeight (@orderWeight n) (phaseExponent c q)) := by + intro n + induction n with + | zero => + intro a p c q + have hap : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + have hcq : phaseExponent c q = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hap, hcq] + simp only [monomialWeight, Finsupp.sum_zero_index, zero_add] + simp only [presentedOrderedMonomial, one_mul] + change (1 : PresentedWeyl k 0) ∈ orderPiece k 0 0 + rw [orderPiece, mem_presentedWeightPiece] + intro m hm + have hone : + presentedNormalFormLinearEquiv k 0 (1 : PresentedWeyl k 0) = 1 := + presentedNormalFormLinearEquiv_one k 0 + rw [hone] at hm + have hm0 : m = 0 := by + symm + simpa [MvPolynomial.coeff_one] using hm + subst m + simp [monomialWeight] + | succ n ih => + intro a p c q + change + presentedCoefficientOrdered k n (a 0) (p 0) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoefficientOrdered k n (c 0) (q 0) + (presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) ∈ _ + rw [presentedCoefficientOrdered_mul] + apply Submodule.sum_mem + intro i hi + have hib : i ≤ p 0 := by + have := Finset.mem_range.mp hi + omega + by_cases hic : i ≤ c 0 + · simp only [if_pos hic] + apply Submodule.smul_mem + have hterm := presentedCoefficientOrdered_mem_orderPiece k + n + (monomialWeight (@orderWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + + monomialWeight (@orderWeight n) + (phaseExponent (fun i => c i.succ) (fun i => q i.succ))) + (a 0 + c 0 - i) (p 0 + q 0 - i) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ) * + presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) + (ih (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ)) + apply presentedWeightPiece_mono k orderWeight _ hterm + rw [monomialWeight_phaseExponent_succ_order, + monomialWeight_phaseExponent_succ_order] + omega + · simp [hic] + +/-- The Bernstein PBW truncations are multiplicatively filtered. -/ +theorem mul_mem_bernsteinPiece {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ bernsteinPiece k n N) (hy : y ∈ bernsteinPiece k n M) : + x * y ∈ bernsteinPiece k n (N + M) := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at hx hy + apply Submodule.span_induction₂ + (p := fun x y _ _ => x * y ∈ bernsteinPiece k n (N + M)) + (ha := hx) (hb := hy) + · intro x y hx hy + obtain ⟨m, hm, rfl⟩ := hx + obtain ⟨r, hr, rfl⟩ := hy + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + have hprod := presentedOrderedMonomial_mul_mem_bernsteinPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + rw [phaseExponent_split, phaseExponent_split] at hprod + exact presentedWeightPiece_mono k bernsteinWeight + (Nat.add_le_add hm hr) hprod + · intro y hy + rw [zero_mul] + exact Submodule.zero_mem _ + · intro x hx + rw [mul_zero] + exact Submodule.zero_mem _ + · intro x y z hx hy hz hxy hyz + rw [add_mul] + exact Submodule.add_mem _ hxy hyz + · intro x y z hx hy hz hxy hxz + rw [mul_add] + exact Submodule.add_mem _ hxy hxz + · intro c x y hx hy hxy + rw [Algebra.smul_mul_assoc] + exact Submodule.smul_mem _ c hxy + · intro c x y hx hy hxy + rw [Algebra.mul_smul_comm] + exact Submodule.smul_mem _ c hxy + +/-- The differential-order PBW truncations are multiplicatively filtered. -/ +theorem mul_mem_orderPiece {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ orderPiece k n N) (hy : y ∈ orderPiece k n M) : + x * y ∈ orderPiece k n (N + M) := by + rw [orderPiece, presentedWeightPiece_eq_span] at hx hy + apply Submodule.span_induction₂ + (p := fun x y _ _ => x * y ∈ orderPiece k n (N + M)) + (ha := hx) (hb := hy) + · intro x y hx hy + obtain ⟨m, hm, rfl⟩ := hx + obtain ⟨r, hr, rfl⟩ := hy + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + have hprod := presentedOrderedMonomial_mul_mem_orderPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + rw [phaseExponent_split, phaseExponent_split] at hprod + exact presentedWeightPiece_mono k orderWeight + (Nat.add_le_add hm hr) hprod + · intro y hy + rw [zero_mul] + exact Submodule.zero_mem _ + · intro x hx + rw [mul_zero] + exact Submodule.zero_mem _ + · intro x y z hx hy hz hxy hyz + rw [add_mul] + exact Submodule.add_mem _ hxy hyz + · intro x y z hx hy hz hxy hxz + rw [mul_add] + exact Submodule.add_mem _ hxy hxz + · intro c x y hx hy hxy + rw [Algebra.smul_mul_assoc] + exact Submodule.smul_mem _ c hxy + · intro c x y hx hy hxy + rw [Algebra.mul_smul_comm] + exact Submodule.smul_mem _ c hxy + +-- Compile-time API contracts: the filtration bounds are exactly additive. +example {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ bernsteinPiece k n N) (hy : y ∈ bernsteinPiece k n M) : + x * y ∈ bernsteinPiece k n (N + M) := + mul_mem_bernsteinPiece k hx hy + +example {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ orderPiece k n N) (hy : y ∈ orderPiece k n M) : + x * y ∈ orderPiece k n (N + M) := + mul_mem_orderPiece k hx hy + +theorem bernsteinPiece_le_orderPiece (n N : ℕ) : + bernsteinPiece k n N ≤ orderPiece k n N := by + apply presentedWeightPiece_antitone_weight k + intro i + cases i <;> simp [orderWeight, fibreWeight, bernsteinWeight] + +theorem exists_mem_bernsteinPiece {n : ℕ} (a : PresentedWeyl k n) : + ∃ N, a ∈ bernsteinPiece k n N := + exists_mem_presentedWeightPiece k bernsteinWeight a + +theorem exists_mem_orderPiece {n : ℕ} (a : PresentedWeyl k n) : + ∃ N, a ∈ orderPiece k n N := + exists_mem_presentedWeightPiece k orderWeight a + + +end + +end Stafford38.WeylFiltration diff --git a/LeanPool/Stafford38/Stafford38/Weyl/GradedAlgebra.lean b/LeanPool/Stafford38/Stafford38/Weyl/GradedAlgebra.lean new file mode 100644 index 0000000000..8a38062fb9 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/GradedAlgebra.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.AssociatedGraded +import Mathlib.Algebra.DirectSum.Decomposition +import Mathlib.Algebra.Ring.TransferInstance +import Mathlib.Algebra.Algebra.TransferInstance + +/-! +# The associated graded algebra of the presented Weyl algebra + +The degree-wise filtered quotients assemble into an external direct sum. Its +canonical symbol map is an algebra equivalence with the commutative symbol +polynomial ring. For the Bernstein and differential-order filtrations, the +transported multiplication is proved to be the multiplication induced by Weyl +products of filtered representatives. +-/ + +namespace Stafford38.WeylAssociatedGraded + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +-- The quotient instances used to define the graded pieces are local to +-- `AssociatedGraded`; restate them here for the external direct sum. +local instance (priority := 10000) presentedAssociatedGradedPieceAddCommGroup' + {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + AddCommGroup (presentedAssociatedGradedPiece k w N) := + @Submodule.Quotient.addCommGroup k (presentedWeightPiece k w N) _ + (presentedWeightPiece k w N).addCommGroup + (presentedWeightPiece k w N).module + (LinearMap.ker (principalComponentOnPiece k w N)) + +local instance (priority := 10000) presentedAssociatedGradedPieceModule' + {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + Module k (presentedAssociatedGradedPiece k w N) := + @Submodule.Quotient.module k (presentedWeightPiece k w N) _ + (presentedWeightPiece k w N).addCommGroup + (presentedWeightPiece k w N).module + (LinearMap.ker (principalComponentOnPiece k w N)) + +/-- The external direct sum of all filtered quotient pieces. This is a new +type so its algebra structure can be transported without changing the +canonical module structures on the individual quotient pieces. -/ +def PresentedAssociatedGraded {n : ℕ} (w : PhaseVar n → ℕ) := + DirectSum ℕ (fun N => presentedAssociatedGradedPiece k w N) + +/-- The direct sum of the piecewise principal-component equivalences, followed +by weighted-homogeneous recomposition. -/ +def presentedAssociatedGradedRawLinearEquiv {n : ℕ} (w : PhaseVar n → ℕ) : + DirectSum ℕ (fun N => presentedAssociatedGradedPiece k w N) ≃ₗ[k] + SymbolRing k n := by + letI := MvPolynomial.weightedDecomposition k w + exact (DFinsupp.mapRange.linearEquiv fun N => + presentedAssociatedGradedPieceEquiv k w N).trans + (DirectSum.decomposeLinearEquiv + (MvPolynomial.weightedHomogeneousSubmodule k w)).symm + +def presentedAssociatedGradedRawEquiv {n : ℕ} (w : PhaseVar n → ℕ) : + PresentedAssociatedGraded k w ≃ SymbolRing k n := + (presentedAssociatedGradedRawLinearEquiv k w).toEquiv + +/-- The commutative ring structure transported through the global symbol +equivalence. The representative multiplication theorems below identify it +with the multiplication induced by the two Weyl filtrations used downstream. -/ +noncomputable instance presentedAssociatedGradedCommRing {n : ℕ} + (w : PhaseVar n → ℕ) : CommRing (PresentedAssociatedGraded k w) := + Equiv.commRing (presentedAssociatedGradedRawEquiv k w) + +noncomputable instance presentedAssociatedGradedAlgebra {n : ℕ} + (w : PhaseVar n → ℕ) : Algebra k (PresentedAssociatedGraded k w) := + Equiv.algebra k (presentedAssociatedGradedRawEquiv k w) + +/-- The associated graded algebra is the commutative symbol polynomial +algebra. -/ +def presentedAssociatedGradedAlgEquiv {n : ℕ} (w : PhaseVar n → ℕ) : + PresentedAssociatedGraded k w ≃ₐ[k] SymbolRing k n := + Equiv.algEquiv k (presentedAssociatedGradedRawEquiv k w) + +/-- Insert one quotient piece into the external direct sum. -/ +def presentedAssociatedGradedOf {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) + (z : presentedAssociatedGradedPiece k w N) : + PresentedAssociatedGraded k w := + DirectSum.of (fun N => presentedAssociatedGradedPiece k w N) N z + +@[simp] theorem presentedAssociatedGradedAlgEquiv_of {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) + (z : presentedAssociatedGradedPiece k w N) : + presentedAssociatedGradedAlgEquiv k w + (presentedAssociatedGradedOf k w N z) = + (presentedAssociatedGradedPieceEquiv k w N z : SymbolRing k n) := by + letI := MvPolynomial.weightedDecomposition k w + change presentedAssociatedGradedRawLinearEquiv k w + (DirectSum.of (fun N => presentedAssociatedGradedPiece k w N) N z) = _ + rw [presentedAssociatedGradedRawLinearEquiv, LinearEquiv.trans_apply] + have hmap : + (DFinsupp.mapRange.linearEquiv fun N => + presentedAssociatedGradedPieceEquiv k w N) + (DirectSum.of (fun N => presentedAssociatedGradedPiece k w N) N z) = + DirectSum.of (fun N => + MvPolynomial.weightedHomogeneousSubmodule k w N) N + (presentedAssociatedGradedPieceEquiv k w N z) := by + rw [DFinsupp.mapRange.linearEquiv_apply] + exact DFinsupp.mapRange_single + calc + _ = (DirectSum.decomposeLinearEquiv + (MvPolynomial.weightedHomogeneousSubmodule k w)).symm + (DirectSum.of (fun N => + MvPolynomial.weightedHomogeneousSubmodule k w N) N + (presentedAssociatedGradedPieceEquiv k w N z)) := + congrArg _ hmap + _ = _ := by + rw [DirectSum.decomposeLinearEquiv_symm_apply, + DirectSum.decompose_symm_of] + +/-- Homogeneous insertion is additive even though the ring structure on the +new external-direct-sum type is transported from the symbol ring. -/ +theorem presentedAssociatedGradedOf_add {n N : ℕ} + (w : PhaseVar n → ℕ) + (x y : presentedAssociatedGradedPiece k w N) : + presentedAssociatedGradedOf k w N (x + y) = + presentedAssociatedGradedOf k w N x + + presentedAssociatedGradedOf k w N y := by + apply (presentedAssociatedGradedAlgEquiv k w).injective + rw [map_add, presentedAssociatedGradedAlgEquiv_of, + presentedAssociatedGradedAlgEquiv_of, + presentedAssociatedGradedAlgEquiv_of] + exact congrArg Subtype.val + ((presentedAssociatedGradedPieceEquiv k w N).map_add x y) + +/-- Insert the class of a filtered representative into the external direct +sum. -/ +def presentedAssociatedGradedMk {n N : ℕ} (w : PhaseVar n → ℕ) + (z : presentedWeightPiece k w N) : PresentedAssociatedGraded k w := + presentedAssociatedGradedOf k w N (Submodule.Quotient.mk z) + +@[simp] theorem presentedAssociatedGradedAlgEquiv_mk {n N : ℕ} + (w : PhaseVar n → ℕ) (z : presentedWeightPiece k w N) : + presentedAssociatedGradedAlgEquiv k w + (presentedAssociatedGradedMk k w z) = + presentedPrincipalComponent k w N z := by + rw [presentedAssociatedGradedMk, presentedAssociatedGradedAlgEquiv_of, + presentedAssociatedGradedPieceEquiv_mk] + rfl + +def bernsteinMulRepresentative {n N M : ℕ} + (x : bernsteinPiece k n N) (y : bernsteinPiece k n M) : + bernsteinPiece k n (N + M) := + ⟨(x : PresentedWeyl k n) * y, + mul_mem_bernsteinPiece k x.property y.property⟩ + +def orderMulRepresentative {n N M : ℕ} + (x : orderPiece k n N) (y : orderPiece k n M) : + orderPiece k n (N + M) := + ⟨(x : PresentedWeyl k n) * y, + mul_mem_orderPiece k x.property y.property⟩ + +/-- On Bernstein-homogeneous classes, external graded multiplication is +represented by multiplication in the Weyl algebra. -/ +theorem presentedAssociatedGradedMk_mul_bernstein {n N M : ℕ} + (x : bernsteinPiece k n N) (y : bernsteinPiece k n M) : + presentedAssociatedGradedMk k bernsteinWeight x * + presentedAssociatedGradedMk k bernsteinWeight y = + presentedAssociatedGradedMk k bernsteinWeight + (bernsteinMulRepresentative k x y) := by + apply (presentedAssociatedGradedAlgEquiv k bernsteinWeight).injective + rw [map_mul, + presentedAssociatedGradedAlgEquiv_mk (n := n) k bernsteinWeight x, + presentedAssociatedGradedAlgEquiv_mk (n := n) k bernsteinWeight y, + presentedAssociatedGradedAlgEquiv_mk (n := n) k bernsteinWeight + (bernsteinMulRepresentative k x y)] + simpa [bernsteinMulRepresentative] using + (presentedPrincipalComponent_mul_bernstein k x.property y.property).symm + +/-- On order-homogeneous classes, external graded multiplication is +represented by multiplication in the Weyl algebra. -/ +theorem presentedAssociatedGradedMk_mul_order {n N M : ℕ} + (x : orderPiece k n N) (y : orderPiece k n M) : + presentedAssociatedGradedMk k orderWeight x * + presentedAssociatedGradedMk k orderWeight y = + presentedAssociatedGradedMk k orderWeight + (orderMulRepresentative k x y) := by + apply (presentedAssociatedGradedAlgEquiv k orderWeight).injective + rw [map_mul, + presentedAssociatedGradedAlgEquiv_mk (n := n) k orderWeight x, + presentedAssociatedGradedAlgEquiv_mk (n := n) k orderWeight y, + presentedAssociatedGradedAlgEquiv_mk (n := n) k orderWeight + (orderMulRepresentative k x y)] + simpa [orderMulRepresentative] using + (presentedPrincipalComponent_mul_order k x.property y.property).symm + +/- Exact statement pins for the public API and focused checker. -/ +example {n : ℕ} (w : PhaseVar n → ℕ) : + PresentedAssociatedGraded k w ≃ₐ[k] SymbolRing k n := + presentedAssociatedGradedAlgEquiv k w + +example {n N : ℕ} (w : PhaseVar n → ℕ) + (z : presentedWeightPiece k w N) : + presentedAssociatedGradedAlgEquiv k w + (presentedAssociatedGradedMk k w z) = + presentedPrincipalComponent k w N z := + presentedAssociatedGradedAlgEquiv_mk k w z + +example {n N M : ℕ} (x : orderPiece k n N) (y : orderPiece k n M) : + presentedAssociatedGradedMk k orderWeight x * + presentedAssociatedGradedMk k orderWeight y = + presentedAssociatedGradedMk k orderWeight + ⟨(x : PresentedWeyl k n) * (y : PresentedWeyl k n), + mul_mem_orderPiece k x.property y.property⟩ := + presentedAssociatedGradedMk_mul_order k x y + + +end + +end Stafford38.WeylAssociatedGraded diff --git a/LeanPool/Stafford38/Stafford38/Weyl/IteratedEquivalence.lean b/LeanPool/Stafford38/Stafford38/Weyl/IteratedEquivalence.lean new file mode 100644 index 0000000000..4b8983afd7 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/IteratedEquivalence.lean @@ -0,0 +1,659 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Ore.IteratedPairStage +import LeanPool.Stafford38.Stafford38.Ore.PairUniversal +import LeanPool.Stafford38.Stafford38.Weyl.Universal + +/-! +# The presented Weyl algebra maps to the iterated Ore construction + +This file constructs mutually inverse algebra maps between the quotient +presentation and the recursively iterated `PairStage`. The proof uses only +the two checked universal properties; it does not assume a PBW theorem for +the quotient presentation. +-/ + +namespace Stafford38.WeylIteratedEquivalence + +open Stafford +open AlgebraicAnalysis +open Stafford38.OrePairStage +open Stafford38.OrePairUniversal +open Stafford38.OreIteratedPairStage +open Stafford38.WeylUniversal + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- The scalar algebra structure inherited recursively by the iterated Ore +tower. -/ +def iteratedPairStageAlgebra : + (n : Nat) → Algebra k (IteratedPairStage k n) + | 0 => by + change Algebra k k + infer_instance + | n + 1 => by + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra n + change Algebra k (PairStage (B := IteratedPairStage k n)) + exact pairStageAlgebra + +instance (n : Nat) : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + +/-- The canonical successor embedding as a scalar-preserving algebra map. -/ +def stageAlgHom (n : Nat) : + IteratedPairStage k n →ₐ[k] IteratedPairStage k (n + 1) where + toRingHom := stageEmbedding k n + commutes' c := by + change pairCoefficient (algebraMap k (IteratedPairStage k n) c) = + @algebraMap k (PairStage (B := IteratedPairStage k n)) _ _ + (pairStageAlgebra (k := k) (B := IteratedPairStage k n)) c + rw [pairStageAlgebra_algebraMap + (k := k) (B := IteratedPairStage k n)] + rfl + +/-- Coordinates in the final stage, ordered from newest to oldest. -/ +def iteratedCoordinate : + (n : Nat) → Fin n → IteratedPairStage k n + | 0, i => Fin.elim0 i + | n + 1, i => + Fin.cases (stageCoordinate k n) + (fun j => stageAlgHom k n (iteratedCoordinate n j)) i + +/-- Momenta in the final stage, ordered from newest to oldest. -/ +def iteratedMomentum : + (n : Nat) → Fin n → IteratedPairStage k n + | 0, i => Fin.elim0 i + | n + 1, i => + Fin.cases (stageMomentum k n) + (fun j => stageAlgHom k n (iteratedMomentum n j)) i + +/-- The combined coordinate-momentum generator family. -/ +def iteratedGenerator (n : Nat) : + (Fin n ⊕ Fin n) → IteratedPairStage k n := + Sum.elim (iteratedCoordinate k n) (iteratedMomentum k n) + +@[simp] theorem iteratedCoordinate_zero (n : Nat) : + iteratedCoordinate k (n + 1) 0 = stageCoordinate k n := rfl + +@[simp] theorem iteratedCoordinate_succ (n : Nat) (i : Fin n) : + iteratedCoordinate k (n + 1) i.succ = + stageAlgHom k n (iteratedCoordinate k n i) := rfl + +@[simp] theorem iteratedMomentum_zero (n : Nat) : + iteratedMomentum k (n + 1) 0 = stageMomentum k n := rfl + +@[simp] theorem iteratedMomentum_succ (n : Nat) (i : Fin n) : + iteratedMomentum k (n + 1) i.succ = + stageAlgHom k n (iteratedMomentum k n i) := rfl + +theorem map_commutator {A C : Type*} [Ring A] [Ring C] + (f : A →+* C) (a b : A) : + f (commutator a b) = commutator (f a) (f b) := by + simp [AlgebraicAnalysis.ringCommutator] + +theorem commutator_swap {A : Type*} [Ring A] (a b : A) : + commutator b a = -commutator a b := by + simp [AlgebraicAnalysis.ringCommutator] + +/-- An element commuting with the image of every presented Weyl generator +commutes with the image of the whole presented algebra. -/ +theorem commutes_freeWeyl_image_of_generators + {ι A : Type*} [Ring A] [Algebra k A] + (omega : Matrix ι ι k) + (f : FreeWeyl k ι omega →ₐ[k] A) (a : A) + (h : ∀ i, a * f (freeWeylGenerator omega i) = + f (freeWeylGenerator omega i) * a) : + ∀ w, a * f w = f w * a := by + intro w + rcases RingQuot.mkAlgHom_surjective k (freeWeylRelation omega) w with + ⟨q, rfl⟩ + let g : FreeAlgebra k ι →ₐ[k] A := + f.comp (RingQuot.mkAlgHom k (freeWeylRelation omega)) + change a * g q = g q * a + induction q using FreeAlgebra.induction k ι with + | grade0 c => + rw [g.commutes] + exact (Algebra.commutes c a).symm + | grade1 i => + change a * f (freeWeylGenerator omega i) = + f (freeWeylGenerator omega i) * a + exact h i + | mul u v hu hv => + rw [map_mul] + calc + a * (g u * g v) = (a * g u) * g v := by rw [mul_assoc] + _ = (g u * a) * g v := by rw [hu] + _ = g u * (a * g v) := by rw [mul_assoc] + _ = g u * (g v * a) := by rw [hv] + _ = (g u * g v) * a := by rw [mul_assoc] + | add u v hu hv => + rw [map_add, mul_add, add_mul, hu, hv] + +/-- All recursively adjoined coordinates commute. -/ +theorem iteratedCoordinate_commutator (n : Nat) : + ∀ i j : Fin n, + commutator (iteratedCoordinate k n i) (iteratedCoordinate k n j) = 0 := by + induction n with + | zero => + intro i + exact Fin.elim0 i + | succ n ih => + intro i j + refine Fin.cases ?_ (fun i => ?_) i + · refine Fin.cases ?_ (fun j => ?_) j + · simp [AlgebraicAnalysis.ringCommutator] + · simp only [iteratedCoordinate_zero, iteratedCoordinate_succ] + exact sub_eq_zero.mpr (stageCoordinate_mul_embedding k n _) + · refine Fin.cases ?_ (fun j => ?_) j + · simp only [iteratedCoordinate_zero, iteratedCoordinate_succ] + exact sub_eq_zero.mpr (stageCoordinate_mul_embedding k n _).symm + · simp only [iteratedCoordinate_succ] + calc + commutator + (stageAlgHom k n (iteratedCoordinate k n i)) + (stageAlgHom k n (iteratedCoordinate k n j)) = + stageAlgHom k n + (commutator (iteratedCoordinate k n i) + (iteratedCoordinate k n j)) := + (map_commutator (stageAlgHom k n).toRingHom _ _).symm + _ = 0 := by rw [ih i j, map_zero] + +/-- All recursively adjoined momenta commute. -/ +theorem iteratedMomentum_commutator (n : Nat) : + ∀ i j : Fin n, + commutator (iteratedMomentum k n i) (iteratedMomentum k n j) = 0 := by + induction n with + | zero => + intro i + exact Fin.elim0 i + | succ n ih => + intro i j + refine Fin.cases ?_ (fun i => ?_) i + · refine Fin.cases ?_ (fun j => ?_) j + · simp [AlgebraicAnalysis.ringCommutator] + · simp only [iteratedMomentum_zero, iteratedMomentum_succ] + exact sub_eq_zero.mpr (stageMomentum_mul_embedding k n _) + · refine Fin.cases ?_ (fun j => ?_) j + · simp only [iteratedMomentum_zero, iteratedMomentum_succ] + exact sub_eq_zero.mpr (stageMomentum_mul_embedding k n _).symm + · simp only [iteratedMomentum_succ] + calc + commutator + (stageAlgHom k n (iteratedMomentum k n i)) + (stageAlgHom k n (iteratedMomentum k n j)) = + stageAlgHom k n + (commutator (iteratedMomentum k n i) + (iteratedMomentum k n j)) := + (map_commutator (stageAlgHom k n).toRingHom _ _).symm + _ = 0 := by rw [ih i j, map_zero] + +/-- Coordinate-momentum commutators are the negative Kronecker delta, in +the convention used by `Matrix.J`. -/ +theorem iteratedCoordinate_momentum_commutator (n : Nat) : + ∀ i j : Fin n, + commutator (iteratedCoordinate k n i) (iteratedMomentum k n j) = + if i = j then -1 else 0 := by + induction n with + | zero => + intro i + exact Fin.elim0 i + | succ n ih => + intro i j + refine Fin.cases ?_ (fun i => ?_) i + · refine Fin.cases ?_ (fun j => ?_) j + · change stageCoordinate k n * stageMomentum k n - + stageMomentum k n * stageCoordinate k n = -1 + rw [stageMomentum_mul_coordinate] + noncomm_ring + · simp only [iteratedCoordinate_zero, iteratedMomentum_succ] + exact sub_eq_zero.mpr (stageCoordinate_mul_embedding k n _) + · refine Fin.cases ?_ (fun j => ?_) j + · simp only [iteratedCoordinate_succ, iteratedMomentum_zero] + simp only [Fin.succ_ne_zero, ↓reduceIte] + exact sub_eq_zero.mpr (stageMomentum_mul_embedding k n _).symm + · simp only [iteratedCoordinate_succ, iteratedMomentum_succ] + calc + commutator + (stageAlgHom k n (iteratedCoordinate k n i)) + (stageAlgHom k n (iteratedMomentum k n j)) = + stageAlgHom k n + (commutator (iteratedCoordinate k n i) + (iteratedMomentum k n j)) := + (map_commutator (stageAlgHom k n).toRingHom _ _).symm + _ = if i.succ = j.succ then -1 else 0 := by + rw [ih i j] + by_cases h : i = j <;> simp [h] + +/-- The combined generator family realizes the standard symplectic +commutator matrix. -/ +theorem iteratedGenerator_commutator (n : Nat) : + ∀ a b : Fin n ⊕ Fin n, + commutator (iteratedGenerator k n a) (iteratedGenerator k n b) = + algebraMap k (IteratedPairStage k n) (Matrix.J (Fin n) k a b) := by + intro a b + cases a with + | inl i => + cases b with + | inl j => + change commutator (iteratedCoordinate k n i) + (iteratedCoordinate k n j) = _ + rw [iteratedCoordinate_commutator] + simp [Matrix.J] + | inr j => + change commutator (iteratedCoordinate k n i) + (iteratedMomentum k n j) = _ + rw [iteratedCoordinate_momentum_commutator] + by_cases h : i = j <;> simp [Matrix.J, h] + | inr i => + cases b with + | inl j => + change commutator (iteratedMomentum k n i) + (iteratedCoordinate k n j) = _ + rw [commutator_swap, + iteratedCoordinate_momentum_commutator] + by_cases h : j = i + · simp [Matrix.J, h] + · have hij : i ≠ j := fun e => h e.symm + simp [Matrix.J, h, hij] + | inr j => + change commutator (iteratedMomentum k n i) + (iteratedMomentum k n j) = _ + rw [iteratedMomentum_commutator] + simp [Matrix.J] + +/-- The canonical map from the presented rank-`n` Weyl algebra to the +recursively iterated Ore construction. -/ +def presentedToIterated (n : Nat) : + FreeWeyl k (Fin n ⊕ Fin n) (Matrix.J (Fin n) k) →ₐ[k] + IteratedPairStage k n := + freeWeylLift (Matrix.J (Fin n) k) (iteratedGenerator k n) + (iteratedGenerator_commutator k n) + +@[simp] theorem presentedToIterated_generator (n : Nat) + (i : Fin n ⊕ Fin n) : + presentedToIterated k n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = + iteratedGenerator k n i := by + exact freeWeylLift_generator (Matrix.J (Fin n) k) + (iteratedGenerator k n) (iteratedGenerator_commutator k n) i + +/-- The quotient presentation of the rank-`n` Weyl algebra. -/ +abbrev PresentedWeyl (n : Nat) := + FreeWeyl k (Fin n ⊕ Fin n) (Matrix.J (Fin n) k) + +/-- Insert an old index after the newly adjoined coordinate or momentum. -/ +def oldIndex {n : Nat} : + (Fin n ⊕ Fin n) → (Fin (n + 1) ⊕ Fin (n + 1)) + | .inl i => .inl i.succ + | .inr i => .inr i.succ + +/-- The old rank-`n` generators inside the rank-`n+1` presentation. -/ +def oldGenerator (n : Nat) (i : Fin n ⊕ Fin n) : PresentedWeyl k (n + 1) := + freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (oldIndex i) + +theorem oldGenerator_commutator (n : Nat) (i j : Fin n ⊕ Fin n) : + commutator (oldGenerator k n i) (oldGenerator k n j) = + algebraMap k (PresentedWeyl k (n + 1)) (Matrix.J (Fin n) k i j) := by + rw [oldGenerator, oldGenerator, freeWeylGenerator_commutator] + cases i with + | inl i => + cases j with + | inl j => simp [oldIndex, Matrix.J] <;> rfl + | inr j => + by_cases h : i = j + · subst j + simp [oldIndex, Matrix.J] + calc + _ = -algebraMap k (PresentedWeyl k (n + 1)) 1 := + map_neg (algebraMap k (PresentedWeyl k (n + 1))) 1 + _ = -1 := by rw [map_one] + · simp [oldIndex, Matrix.J, h] <;> rfl + | inr i => + cases j with + | inl j => + by_cases h : i = j <;> + simp [oldIndex, Matrix.J, h] <;> rfl + | inr j => simp [oldIndex, Matrix.J] <;> rfl + +/-- The canonical rank-shift embedding preserving the old generators. -/ +def previousWeylEmbedding (n : Nat) : + PresentedWeyl k n →ₐ[k] PresentedWeyl k (n + 1) := + freeWeylLift (Matrix.J (Fin n) k) (oldGenerator k n) + (oldGenerator_commutator k n) + +@[simp] theorem previousWeylEmbedding_generator (n : Nat) + (i : Fin n ⊕ Fin n) : + previousWeylEmbedding k n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = oldGenerator k n i := by + exact freeWeylLift_generator (Matrix.J (Fin n) k) (oldGenerator k n) + (oldGenerator_commutator k n) i + +/-- The newest coordinate in the rank-`n+1` presentation. -/ +def presentedCoordinate (n : Nat) : PresentedWeyl k (n + 1) := + freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl 0) + +/-- The newest momentum in the rank-`n+1` presentation. -/ +def presentedMomentum (n : Nat) : PresentedWeyl k (n + 1) := + freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr 0) + +theorem presentedCoordinate_commutes_oldGenerator (n : Nat) + (i : Fin n ⊕ Fin n) : + presentedCoordinate k n * oldGenerator k n i = + oldGenerator k n i * presentedCoordinate k n := by + apply sub_eq_zero.mp + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin (n + 1)) k) + (.inl (0 : Fin (n + 1))) (oldIndex i) + cases i with + | inl i => + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl i.succ)) = + algebraMap k (PresentedWeyl k (n + 1)) 0 at h + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl i.succ)) = 0 + rw [map_zero] at h + exact h + | inr i => + have hi : (0 : Fin (n + 1)) ≠ i.succ := i.succ_ne_zero.symm + simp only [oldIndex] at h + have hJ : Matrix.J (Fin (n + 1)) k (.inl 0) (.inr i.succ) = 0 := by + simp [Matrix.J, hi] + rw [hJ] at h + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr i.succ)) = 0 + rw [map_zero] at h + exact h + +theorem presentedMomentum_commutes_oldGenerator (n : Nat) + (i : Fin n ⊕ Fin n) : + presentedMomentum k n * oldGenerator k n i = + oldGenerator k n i * presentedMomentum k n := by + apply sub_eq_zero.mp + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin (n + 1)) k) + (.inr (0 : Fin (n + 1))) (oldIndex i) + cases i with + | inl i => + have hi : (0 : Fin (n + 1)) ≠ i.succ := i.succ_ne_zero.symm + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl i.succ)) = + algebraMap k (PresentedWeyl k (n + 1)) 0 at h + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inl i.succ)) = 0 + rw [map_zero] at h + exact h + | inr i => + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr i.succ)) = + algebraMap k (PresentedWeyl k (n + 1)) 0 at h + change Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr 0)) + (freeWeylGenerator (Matrix.J (Fin (n + 1)) k) (.inr i.succ)) = 0 + rw [map_zero] at h + exact h + +theorem presentedCoordinate_commutes_previous (n : Nat) : + ∀ w : PresentedWeyl k n, + presentedCoordinate k n * previousWeylEmbedding k n w = + previousWeylEmbedding k n w * presentedCoordinate k n := + commutes_freeWeyl_image_of_generators k (Matrix.J (Fin n) k) + (previousWeylEmbedding k n) (presentedCoordinate k n) (by + intro i + simpa using presentedCoordinate_commutes_oldGenerator k n i) + +theorem presentedMomentum_commutes_previous (n : Nat) : + ∀ w : PresentedWeyl k n, + presentedMomentum k n * previousWeylEmbedding k n w = + previousWeylEmbedding k n w * presentedMomentum k n := + commutes_freeWeyl_image_of_generators k (Matrix.J (Fin n) k) + (previousWeylEmbedding k n) (presentedMomentum k n) (by + intro i + simpa using presentedMomentum_commutes_oldGenerator k n i) + +theorem presentedMomentum_mul_coordinate (n : Nat) : + presentedMomentum k n * presentedCoordinate k n = + presentedCoordinate k n * presentedMomentum k n + 1 := by + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin (n + 1)) k) + (.inr (0 : Fin (n + 1))) (.inl (0 : Fin (n + 1))) + change Stafford.commutator (presentedMomentum k n) + (presentedCoordinate k n) = algebraMap k (PresentedWeyl k (n + 1)) 1 at h + rw [map_one] at h + change presentedMomentum k n * presentedCoordinate k n - + presentedCoordinate k n * presentedMomentum k n = 1 at h + calc + presentedMomentum k n * presentedCoordinate k n = + (presentedMomentum k n * presentedCoordinate k n - + presentedCoordinate k n * presentedMomentum k n) + + presentedCoordinate k n * presentedMomentum k n := by noncomm_ring + _ = 1 + presentedCoordinate k n * presentedMomentum k n := by rw [h] + _ = presentedCoordinate k n * presentedMomentum k n + 1 := add_comm _ _ + +/-- The recursive map from the Ore tower back to the quotient presentation. -/ +def iteratedToPresented : + (n : Nat) → IteratedPairStage k n →ₐ[k] PresentedWeyl k n + | 0 => Algebra.ofId k (PresentedWeyl k 0) + | n + 1 => by + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + change PairStage (B := IteratedPairStage k n) →ₐ[k] + PresentedWeyl k (n + 1) + let f : IteratedPairStage k n →ₐ[k] PresentedWeyl k (n + 1) := + (previousWeylEmbedding k n).comp (iteratedToPresented n) + exact pairLiftAlgHom f (presentedCoordinate k n) (presentedMomentum k n) + (fun b => presentedCoordinate_commutes_previous k n + (iteratedToPresented n b)) + (fun b => presentedMomentum_commutes_previous k n + (iteratedToPresented n b)) + (presentedMomentum_mul_coordinate k n) + +@[simp] theorem iteratedToPresented_coefficient (n : Nat) + (b : IteratedPairStage k n) : + iteratedToPresented k (n + 1) (stageEmbedding k n b) = + previousWeylEmbedding k n (iteratedToPresented k n b) := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := pairStageAlgebra + change pairLiftAlgHom _ _ _ _ _ _ (pairCoefficient b) = _ + exact pairLiftAlgHom_coefficient _ _ _ _ _ _ b + +@[simp] theorem iteratedToPresented_coordinate (n : Nat) : + iteratedToPresented k (n + 1) (stageCoordinate k n) = + presentedCoordinate k n := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := pairStageAlgebra + change pairLiftAlgHom _ _ _ _ _ _ pairCoordinate = _ + exact pairLiftAlgHom_coordinate _ _ _ _ _ _ + +@[simp] theorem iteratedToPresented_momentum (n : Nat) : + iteratedToPresented k (n + 1) (stageMomentum k n) = + presentedMomentum k n := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := pairStageAlgebra + change pairLiftAlgHom _ _ _ _ _ _ pairMomentum = _ + exact pairLiftAlgHom_momentum _ _ _ _ _ _ + +theorem presentedToIterated_previous (n : Nat) : + (presentedToIterated k (n + 1)).comp (previousWeylEmbedding k n) = + (stageAlgHom k n).comp (presentedToIterated k n) := by + apply freeWeyl_algHom_ext + intro i + simp only [AlgHom.comp_apply, previousWeylEmbedding_generator, + presentedToIterated_generator] + cases i <;> unfold oldGenerator oldIndex <;> + rw [presentedToIterated_generator] <;> rfl + +@[simp] theorem presentedToIterated_coordinate (n : Nat) : + presentedToIterated k (n + 1) (presentedCoordinate k n) = + stageCoordinate k n := by + unfold presentedCoordinate + rw [presentedToIterated_generator] + rfl + +@[simp] theorem presentedToIterated_momentum (n : Nat) : + presentedToIterated k (n + 1) (presentedMomentum k n) = + stageMomentum k n := by + unfold presentedMomentum + rw [presentedToIterated_generator] + rfl + +/-- Mapping from the Ore tower to the presentation and back is the identity. -/ +theorem presentedToIterated_comp_iteratedToPresented : + ∀ n : Nat, + (presentedToIterated k n).comp (iteratedToPresented k n) = + AlgHom.id k (IteratedPairStage k n) := by + intro n + induction n with + | zero => + apply AlgHom.ext + intro c + change k at c + change presentedToIterated k 0 + (algebraMap k (PresentedWeyl k 0) c) = c + rw [(presentedToIterated k 0).commutes] + rfl + | succ n ih => + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + let f : IteratedPairStage k n →ₐ[k] IteratedPairStage k (n + 1) := + stageAlgHom k n + let X : IteratedPairStage k (n + 1) := stageCoordinate k n + let P : IteratedPairStage k (n + 1) := stageMomentum k n + let g : IteratedPairStage k (n + 1) →ₐ[k] + IteratedPairStage k (n + 1) := + (presentedToIterated k (n + 1)).comp + (iteratedToPresented k (n + 1)) + have hgCoefficient : ∀ b, g (stageEmbedding k n b) = f b := by + intro b + dsimp [g, f] + rw [iteratedToPresented_coefficient] + have hp := DFunLike.congr_fun (presentedToIterated_previous k n) + (iteratedToPresented k n b) + calc + presentedToIterated k (n + 1) + (previousWeylEmbedding k n (iteratedToPresented k n b)) = + stageAlgHom k n + (presentedToIterated k n (iteratedToPresented k n b)) := hp + _ = stageAlgHom k n b := by + have hib : presentedToIterated k n (iteratedToPresented k n b) = b := by + change ((presentedToIterated k n).comp + (iteratedToPresented k n)) b = b + rw [ih] + rfl + rw [hib] + have hgCoordinate : g (stageCoordinate k n) = X := by + dsimp [g, X] + rw [iteratedToPresented_coordinate, presentedToIterated_coordinate] + have hgMomentum : g (stageMomentum k n) = P := by + dsimp [g, P] + rw [iteratedToPresented_momentum, presentedToIterated_momentum] + have hg : g = pairLiftAlgHom f X P + (stageCoordinate_mul_embedding k n) + (stageMomentum_mul_embedding k n) + (stageMomentum_mul_coordinate k n) := + pairLiftAlgHom_unique f X P + (stageCoordinate_mul_embedding k n) + (stageMomentum_mul_embedding k n) + (stageMomentum_mul_coordinate k n) g + hgCoefficient hgCoordinate hgMomentum + have hid : AlgHom.id k (IteratedPairStage k (n + 1)) = + pairLiftAlgHom f X P + (stageCoordinate_mul_embedding k n) + (stageMomentum_mul_embedding k n) + (stageMomentum_mul_coordinate k n) := + pairLiftAlgHom_unique f X P + (stageCoordinate_mul_embedding k n) + (stageMomentum_mul_embedding k n) + (stageMomentum_mul_coordinate k n) + (AlgHom.id k (IteratedPairStage k (n + 1))) + (fun _ => rfl) rfl rfl + exact hg.trans hid.symm + +/-- The recursive inverse sends every iterated generator back to its named +generator in the quotient presentation. -/ +theorem iteratedToPresented_generator : + ∀ (n : Nat) (i : Fin n ⊕ Fin n), + iteratedToPresented k n (iteratedGenerator k n i) = + freeWeylGenerator (Matrix.J (Fin n) k) i := by + intro n + induction n with + | zero => + intro i + exact Sum.elim Fin.elim0 Fin.elim0 i + | succ n ih => + intro i + cases i with + | inl i => + refine Fin.cases ?_ (fun j => ?_) i + · change iteratedToPresented k (n + 1) (stageCoordinate k n) = _ + rw [iteratedToPresented_coordinate] + rfl + · change iteratedToPresented k (n + 1) + (stageEmbedding k n (iteratedCoordinate k n j)) = _ + rw [iteratedToPresented_coefficient] + change previousWeylEmbedding k n + (iteratedToPresented k n (iteratedGenerator k n (.inl j))) = _ + rw [ih (.inl j), previousWeylEmbedding_generator] + rfl + | inr i => + refine Fin.cases ?_ (fun j => ?_) i + · change iteratedToPresented k (n + 1) (stageMomentum k n) = _ + rw [iteratedToPresented_momentum] + rfl + · change iteratedToPresented k (n + 1) + (stageEmbedding k n (iteratedMomentum k n j)) = _ + rw [iteratedToPresented_coefficient] + change previousWeylEmbedding k n + (iteratedToPresented k n (iteratedGenerator k n (.inr j))) = _ + rw [ih (.inr j), previousWeylEmbedding_generator] + rfl + +/-- Mapping from the quotient presentation to the Ore tower and back is the +identity. -/ +theorem iteratedToPresented_comp_presentedToIterated (n : Nat) : + (iteratedToPresented k n).comp (presentedToIterated k n) = + AlgHom.id k (PresentedWeyl k n) := by + apply freeWeyl_algHom_ext + intro i + rw [AlgHom.comp_apply, presentedToIterated_generator, + iteratedToPresented_generator] + rfl + +/-- The quotient presentation is canonically equivalent to the recursive +Ore construction, without using PBW independence for the quotient. -/ +def presentedIteratedEquiv (n : Nat) : + PresentedWeyl k n ≃ₐ[k] IteratedPairStage k n := + AlgEquiv.ofAlgHom (presentedToIterated k n) (iteratedToPresented k n) + (presentedToIterated_comp_iteratedToPresented k n) + (iteratedToPresented_comp_presentedToIterated k n) + +@[simp] theorem presentedIteratedEquiv_generator (n : Nat) + (i : Fin n ⊕ Fin n) : + presentedIteratedEquiv k n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = + iteratedGenerator k n i := by + exact presentedToIterated_generator k n i + + +end + +end Stafford38.WeylIteratedEquivalence diff --git a/LeanPool/Stafford38/Stafford38/Weyl/LeadingSymbol.lean b/LeanPool/Stafford38/Stafford38/Weyl/LeadingSymbol.lean new file mode 100644 index 0000000000..476e23595f --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/LeadingSymbol.lean @@ -0,0 +1,661 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.Filtration +import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous + +/-! +# Principal components and leading-symbol multiplication + +Weighted homogeneous projection of the checked PBW normal form defines the +degree-`N` principal component of a filtered Weyl element. Exact one-pair +normal ordering proves that, for both the Bernstein and differential-order +filtrations, the principal component of a product is the product of the +principal components. No associated graded identification is assumed here. +-/ + +namespace Stafford38.WeylLeadingSymbol + +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBW +open Stafford38.WeylFiltration + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +theorem finsupp_weight_eq_monomialWeight {n : ℕ} + (w : PhaseVar n → ℕ) (m : PhaseVar n →₀ ℕ) : + Finsupp.weight w m = monomialWeight w m := by + rfl + +/-- The homogeneous component at the declared filtration bound `N`. It is zero +when the element has strictly smaller actual weighted degree. -/ +def presentedPrincipalComponent {n : ℕ} (w : PhaseVar n → ℕ) (N : ℕ) : + PresentedWeyl k n →ₗ[k] SymbolRing k n := + (MvPolynomial.weightedHomogeneousComponent w N).comp + (presentedNormalFormLinearEquiv k n).toLinearMap + +theorem coeff_presentedPrincipalComponent {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) (z : PresentedWeyl k n) + (m : PhaseVar n →₀ ℕ) : + MvPolynomial.coeff m (presentedPrincipalComponent k w N z) = + if monomialWeight w m = N then + MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n z) + else 0 := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + MvPolynomial.coeff_weightedHomogeneousComponent, + finsupp_weight_eq_monomialWeight] + rfl + +theorem presentedPrincipalComponent_eq_zero_of_mem_of_lt {n L T : ℕ} + (w : PhaseVar n → ℕ) (z : PresentedWeyl k n) + (hz : z ∈ presentedWeightPiece k w L) (hLT : L < T) : + presentedPrincipalComponent k w T z = 0 := by + ext m + rw [coeff_presentedPrincipalComponent] + by_cases hm : monomialWeight w m = T + · rw [if_pos hm] + have hcoeff : + MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n z) = 0 := by + by_contra hne + have hle := (mem_presentedWeightPiece k w L z).mp hz m hne + omega + rw [hcoeff, MvPolynomial.coeff_zero] + · rw [if_neg hm, MvPolynomial.coeff_zero] + +theorem presentedPrincipalComponent_basis {n : ℕ} + (w : PhaseVar n → ℕ) (N : ℕ) (m : PhaseVar n →₀ ℕ) : + presentedPrincipalComponent k w N (presentedPBWBasis k n m) = + if monomialWeight w m = N then MvPolynomial.monomial m 1 else 0 := by + classical + ext q + rw [coeff_presentedPrincipalComponent, + presentedNormalFormLinearEquiv_basis] + by_cases hm : monomialWeight w m = N + · rw [if_pos hm, MvPolynomial.coeff_monomial] + by_cases hmq : m = q + · subst q + simp [hm] + · simp [hmq, Ne.symm hmq] + · rw [if_neg hm, MvPolynomial.coeff_zero] + by_cases hqm : q = m + · subst q + simp [hm] + · simp [hqm, Ne.symm hqm] + +theorem weightedHomogeneousComponent_monomial {n N : ℕ} + (w : PhaseVar n → ℕ) (m : PhaseVar n →₀ ℕ) (c : k) : + MvPolynomial.weightedHomogeneousComponent w N + (MvPolynomial.monomial m c) = + if monomialWeight w m = N then MvPolynomial.monomial m c else 0 := by + classical + ext q + rw [MvPolynomial.coeff_weightedHomogeneousComponent, + finsupp_weight_eq_monomialWeight] + by_cases hm : monomialWeight w m = N + · rw [if_pos hm, MvPolynomial.coeff_monomial] + by_cases hmq : m = q + · subst q + simp [hm] + · simp [hmq, Ne.symm hmq] + · rw [if_neg hm, MvPolynomial.coeff_zero] + by_cases hqm : q = m + · subst q + simp [hm] + · simp [hqm, Ne.symm hqm] + +theorem weightedHomogeneousComponent_rename + {n r T : ℕ} (wOld : PhaseVar n → ℕ) (wNew : PhaseVar r → ℕ) + (e : PhaseVar n → PhaseVar r) + (hweight : ∀ m : PhaseVar n →₀ ℕ, + monomialWeight wNew (m.mapDomain e) = monomialWeight wOld m) + (f : SymbolRing k n) : + MvPolynomial.weightedHomogeneousComponent wNew T + (MvPolynomial.rename e f) = + MvPolynomial.rename e + (MvPolynomial.weightedHomogeneousComponent wOld T f) := by + classical + induction f using MvPolynomial.induction_on' with + | monomial m c => + rw [MvPolynomial.rename_monomial, + weightedHomogeneousComponent_monomial, + weightedHomogeneousComponent_monomial, hweight] + by_cases h : monomialWeight wOld m = T + · simp [h, MvPolynomial.rename_monomial] + · simp [h] + | add p q hp hq => + simp [map_add, hp, hq] + +theorem weightedHomogeneousComponent_monomial_mul {n T : ℕ} + (w : PhaseVar n → ℕ) (s : PhaseVar n →₀ ℕ) + (f : SymbolRing k n) : + MvPolynomial.weightedHomogeneousComponent w + (T + monomialWeight w s) (MvPolynomial.monomial s 1 * f) = + MvPolynomial.monomial s 1 * + MvPolynomial.weightedHomogeneousComponent w T f := by + classical + ext q + rw [MvPolynomial.coeff_weightedHomogeneousComponent, + MvPolynomial.coeff_monomial_mul', + MvPolynomial.coeff_monomial_mul'] + by_cases hsq : s ≤ q + · rw [if_pos hsq, if_pos hsq, one_mul, one_mul, + MvPolynomial.coeff_weightedHomogeneousComponent] + have hsplit : s + (q - s) = q := by + rw [add_comm] + exact tsub_add_cancel_of_le hsq + have hweight : + monomialWeight w q = + monomialWeight w s + monomialWeight w (q - s) := by + rw [← hsplit] + simp [monomialWeight, Finsupp.sum_add_index, add_mul] + rw [finsupp_weight_eq_monomialWeight, + finsupp_weight_eq_monomialWeight] + rw [hweight] + by_cases hrest : monomialWeight w (q - s) = T + · simp [hrest, Nat.add_comm] + · have hne : + monomialWeight w s + monomialWeight w (q - s) ≠ + T + monomialWeight w s := by + omega + simp [hrest, hne] + · rw [if_neg hsq, if_neg hsq] + simp + +theorem monomialWeight_mapDomain_oldIndex_bernstein (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + monomialWeight (@bernsteinWeight (n + 1)) (m.mapDomain oldIndex) = + monomialWeight (@bernsteinWeight n) m := by + have h := monomialWeight_extend_bernstein n 0 0 m + simpa [extendPhaseExponent] using h.symm + +theorem monomialWeight_mapDomain_oldIndex_order (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + monomialWeight (@orderWeight (n + 1)) (m.mapDomain oldIndex) = + monomialWeight (@orderWeight n) m := by + have h := monomialWeight_extend_order n 0 0 m + simpa [extendPhaseExponent] using h.symm + +theorem presentedNormalFormLinearEquiv_previous_ordered_monomial + (n a p : ℕ) (z : PresentedWeyl k n) : + presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p z) = + MvPolynomial.monomial (extendPhaseExponent n a p 0) 1 * + MvPolynomial.rename oldIndex + (presentedNormalFormLinearEquiv k n z) := by + rw [presentedNormalFormLinearEquiv_previous_ordered, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.monomial_mul] + simp [extendPhaseExponent] + +theorem monomialWeight_extend_zero_bernstein (n a p : ℕ) : + monomialWeight (@bernsteinWeight (n + 1)) + (extendPhaseExponent n a p 0) = a + p := by + rw [← monomialWeight_extend_bernstein] + simp [monomialWeight] + +theorem monomialWeight_extend_zero_order (n a p : ℕ) : + monomialWeight (@orderWeight (n + 1)) + (extendPhaseExponent n a p 0) = p := by + rw [← monomialWeight_extend_order] + simp [monomialWeight] + +theorem presentedPrincipalComponent_coefficientOrdered_bernstein + (n N a p : ℕ) (z : PresentedWeyl k n) : + presentedPrincipalComponent k (@bernsteinWeight (n + 1)) (N + a + p) + (presentedCoefficientOrdered k n a p z) = + MvPolynomial.monomial (extendPhaseExponent n a p 0) 1 * + MvPolynomial.rename oldIndex + (presentedPrincipalComponent k (@bernsteinWeight n) N z) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + show N + a + p = N + monomialWeight (@bernsteinWeight (n + 1)) + (extendPhaseExponent n a p 0) by + rw [monomialWeight_extend_zero_bernstein] + omega] + change MvPolynomial.weightedHomogeneousComponent + (@bernsteinWeight (n + 1)) + (N + monomialWeight (@bernsteinWeight (n + 1)) + (extendPhaseExponent n a p 0)) + (presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p z)) = _ + rw [presentedNormalFormLinearEquiv_previous_ordered_monomial] + rw [weightedHomogeneousComponent_monomial_mul, + weightedHomogeneousComponent_rename + k (@bernsteinWeight n) (@bernsteinWeight (n + 1)) oldIndex + (monomialWeight_mapDomain_oldIndex_bernstein n)] + rfl + +theorem presentedPrincipalComponent_coefficientOrdered_order + (n N a p : ℕ) (z : PresentedWeyl k n) : + presentedPrincipalComponent k (@orderWeight (n + 1)) (N + p) + (presentedCoefficientOrdered k n a p z) = + MvPolynomial.monomial (extendPhaseExponent n a p 0) 1 * + MvPolynomial.rename oldIndex + (presentedPrincipalComponent k (@orderWeight n) N z) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + show N + p = N + monomialWeight (@orderWeight (n + 1)) + (extendPhaseExponent n a p 0) by + rw [monomialWeight_extend_zero_order]] + change MvPolynomial.weightedHomogeneousComponent + (@orderWeight (n + 1)) + (N + monomialWeight (@orderWeight (n + 1)) + (extendPhaseExponent n a p 0)) + (presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p z)) = _ + rw [presentedNormalFormLinearEquiv_previous_ordered_monomial] + rw [weightedHomogeneousComponent_monomial_mul, + weightedHomogeneousComponent_rename + k (@orderWeight n) (@orderWeight (n + 1)) oldIndex + (monomialWeight_mapDomain_oldIndex_order n)] + rfl + +theorem phaseMonomial_succ_product (n : ℕ) + (a p c q : Fin (n + 1) → ℕ) : + MvPolynomial.monomial (phaseExponent a p) (1 : k) * + MvPolynomial.monomial (phaseExponent c q) 1 = + MvPolynomial.monomial + (extendPhaseExponent n (a 0 + c 0) (p 0 + q 0) 0) 1 * + MvPolynomial.rename oldIndex + (MvPolynomial.monomial + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) 1 * + MvPolynomial.monomial + (phaseExponent (fun i => c i.succ) (fun i => q i.succ)) 1) := by + have hexp : + phaseExponent a p + phaseExponent c q = + extendPhaseExponent n (a 0 + c 0) (p 0 + q 0) 0 + + (phaseExponent (fun i => a i.succ) (fun i => p i.succ) + + phaseExponent (fun i => c i.succ) (fun i => q i.succ)).mapDomain + oldIndex := by + rw [phaseExponent_succ_eq_extend, phaseExponent_succ_eq_extend] + simp [extendPhaseExponent, map_add, add_assoc, add_comm, add_left_comm] + rw [Finsupp.mapDomain_add] + rw [MvPolynomial.monomial_mul, MvPolynomial.monomial_mul, + MvPolynomial.rename_monomial, MvPolynomial.monomial_mul] + simp only [one_mul] + rw [hexp] + +theorem presentedOrderedMonomial_mul_principal_bernstein : + ∀ (n : ℕ) (a p c q : Fin n → ℕ), + presentedPrincipalComponent k (@bernsteinWeight n) + (monomialWeight (@bernsteinWeight n) (phaseExponent a p) + + monomialWeight (@bernsteinWeight n) (phaseExponent c q)) + (presentedOrderedMonomial k n a p * + presentedOrderedMonomial k n c q) = + MvPolynomial.monomial (phaseExponent a p) 1 * + MvPolynomial.monomial (phaseExponent c q) 1 := by + intro n + induction n with + | zero => + intro a p c q + have hap : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + have hcq : phaseExponent c q = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hap, hcq] + simp [presentedOrderedMonomial, monomialWeight, + presentedPrincipalComponent, presentedNormalFormLinearEquiv_one, + weightedHomogeneousComponent_monomial] + | succ n ih => + intro a p c q + let L := + monomialWeight (@bernsteinWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + + monomialWeight (@bernsteinWeight n) + (phaseExponent (fun i => c i.succ) (fun i => q i.succ)) + have htarget : + monomialWeight (@bernsteinWeight (n + 1)) (phaseExponent a p) + + monomialWeight (@bernsteinWeight (n + 1)) (phaseExponent c q) = + L + (a 0 + c 0) + (p 0 + q 0) := by + rw [monomialWeight_phaseExponent_succ_bernstein, + monomialWeight_phaseExponent_succ_bernstein] + simp only [L] + omega + rw [htarget] + change + presentedPrincipalComponent k (@bernsteinWeight (n + 1)) + (L + (a 0 + c 0) + (p 0 + q 0)) + (presentedCoefficientOrdered k n (a 0) (p 0) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoefficientOrdered k n (c 0) (q 0) + (presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ))) = _ + rw [presentedCoefficientOrdered_mul] + simp only [map_sum] + rw [Finset.sum_eq_single 0] + · simp only [Nat.zero_le, if_true, Nat.choose_zero_right, + Nat.descFactorial_zero, mul_one, one_nsmul, Nat.sub_zero] + rw [presentedPrincipalComponent_coefficientOrdered_bernstein] + have hih := ih + (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ) + change presentedPrincipalComponent k (@bernsteinWeight n) L + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ) * + presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) = _ at hih + rw [hih] + exact (phaseMonomial_succ_product k n a p c q).symm + · intro i hi hi0 + have hib : i ≤ p 0 := by + have := Finset.mem_range.mp hi + omega + by_cases hic : i ≤ c 0 + · simp only [if_pos hic] + have hold : + presentedOrderedMonomial k n + (fun j => a j.succ) (fun j => p j.succ) * + presentedOrderedMonomial k n + (fun j => c j.succ) (fun j => q j.succ) ∈ + bernsteinPiece k n L := by + simpa [L] using + presentedOrderedMonomial_mul_mem_bernsteinPiece k n + (fun j => a j.succ) (fun j => p j.succ) + (fun j => c j.succ) (fun j => q j.succ) + have hterm := presentedCoefficientOrdered_mem_bernsteinPiece k n L + (a 0 + c 0 - i) (p 0 + q 0 - i) + (presentedOrderedMonomial k n + (fun j => a j.succ) (fun j => p j.succ) * + presentedOrderedMonomial k n + (fun j => c j.succ) (fun j => q j.succ)) hold + have hlt : + L + (a 0 + c 0 - i) + (p 0 + q 0 - i) < + L + (a 0 + c 0) + (p 0 + q 0) := by + omega + have hz := presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@bernsteinWeight (n + 1)) _ hterm hlt + rw [map_nsmul, hz, nsmul_zero] + · simp [hic] + · simp + +theorem presentedOrderedMonomial_mul_principal_order : + ∀ (n : ℕ) (a p c q : Fin n → ℕ), + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) (phaseExponent a p) + + monomialWeight (@orderWeight n) (phaseExponent c q)) + (presentedOrderedMonomial k n a p * + presentedOrderedMonomial k n c q) = + MvPolynomial.monomial (phaseExponent a p) 1 * + MvPolynomial.monomial (phaseExponent c q) 1 := by + intro n + induction n with + | zero => + intro a p c q + have hap : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + have hcq : phaseExponent c q = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hap, hcq] + simp [presentedOrderedMonomial, monomialWeight, + presentedPrincipalComponent, presentedNormalFormLinearEquiv_one, + weightedHomogeneousComponent_monomial] + | succ n ih => + intro a p c q + let L := + monomialWeight (@orderWeight n) + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + + monomialWeight (@orderWeight n) + (phaseExponent (fun i => c i.succ) (fun i => q i.succ)) + have htarget : + monomialWeight (@orderWeight (n + 1)) (phaseExponent a p) + + monomialWeight (@orderWeight (n + 1)) (phaseExponent c q) = + L + (p 0 + q 0) := by + rw [monomialWeight_phaseExponent_succ_order, + monomialWeight_phaseExponent_succ_order] + simp only [L] + omega + rw [htarget] + change + presentedPrincipalComponent k (@orderWeight (n + 1)) + (L + (p 0 + q 0)) + (presentedCoefficientOrdered k n (a 0) (p 0) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoefficientOrdered k n (c 0) (q 0) + (presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ))) = _ + rw [presentedCoefficientOrdered_mul] + simp only [map_sum] + rw [Finset.sum_eq_single 0] + · simp only [Nat.zero_le, if_true, Nat.choose_zero_right, + Nat.descFactorial_zero, mul_one, one_nsmul, Nat.sub_zero] + rw [presentedPrincipalComponent_coefficientOrdered_order] + have hih := ih + (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ) + change presentedPrincipalComponent k (@orderWeight n) L + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ) * + presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ)) = _ at hih + rw [hih] + exact (phaseMonomial_succ_product k n a p c q).symm + · intro i hi hi0 + have hib : i ≤ p 0 := by + have := Finset.mem_range.mp hi + omega + by_cases hic : i ≤ c 0 + · simp only [if_pos hic] + have hold : + presentedOrderedMonomial k n + (fun j => a j.succ) (fun j => p j.succ) * + presentedOrderedMonomial k n + (fun j => c j.succ) (fun j => q j.succ) ∈ + orderPiece k n L := by + simpa [L] using + presentedOrderedMonomial_mul_mem_orderPiece k n + (fun j => a j.succ) (fun j => p j.succ) + (fun j => c j.succ) (fun j => q j.succ) + have hterm := presentedCoefficientOrdered_mem_orderPiece k n L + (a 0 + c 0 - i) (p 0 + q 0 - i) + (presentedOrderedMonomial k n + (fun j => a j.succ) (fun j => p j.succ) * + presentedOrderedMonomial k n + (fun j => c j.succ) (fun j => q j.succ)) hold + have hlt : + L + (p 0 + q 0 - i) < L + (p 0 + q 0) := by + omega + have hz := presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight (n + 1)) _ hterm hlt + rw [map_nsmul, hz, nsmul_zero] + · simp [hic] + · simp + +theorem presentedPBWBasis_mul_principal_bernstein {n : ℕ} + (m r : PhaseVar n →₀ ℕ) : + presentedPrincipalComponent k (@bernsteinWeight n) + (monomialWeight (@bernsteinWeight n) m + + monomialWeight (@bernsteinWeight n) r) + (presentedPBWBasis k n m * presentedPBWBasis k n r) = + MvPolynomial.monomial m 1 * MvPolynomial.monomial r 1 := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply, + ← phaseExponent_split m, ← phaseExponent_split r] + exact presentedOrderedMonomial_mul_principal_bernstein k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + +theorem presentedPBWBasis_mul_principal_order {n : ℕ} + (m r : PhaseVar n →₀ ℕ) : + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) r) + (presentedPBWBasis k n m * presentedPBWBasis k n r) = + MvPolynomial.monomial m 1 * MvPolynomial.monomial r 1 := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply, + ← phaseExponent_split m, ← phaseExponent_split r] + exact presentedOrderedMonomial_mul_principal_order k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + +theorem presentedPrincipalComponent_mul_bernstein + {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ bernsteinPiece k n N) (hy : y ∈ bernsteinPiece k n M) : + presentedPrincipalComponent k (@bernsteinWeight n) (N + M) (x * y) = + presentedPrincipalComponent k (@bernsteinWeight n) N x * + presentedPrincipalComponent k (@bernsteinWeight n) M y := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at hx hy + apply Submodule.span_induction₂ + (p := fun x y _ _ => + presentedPrincipalComponent k (@bernsteinWeight n) (N + M) (x * y) = + presentedPrincipalComponent k (@bernsteinWeight n) N x * + presentedPrincipalComponent k (@bernsteinWeight n) M y) + (ha := hx) (hb := hy) + · intro bx bz hbx hbz + obtain ⟨m, hm, rfl⟩ := hbx + obtain ⟨r, hr, rfl⟩ := hbz + by_cases hmN : monomialWeight (@bernsteinWeight n) m = N + · by_cases hrM : monomialWeight (@bernsteinWeight n) r = M + · rw [← hmN, ← hrM, + presentedPBWBasis_mul_principal_bernstein, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp + · have hrlt : monomialWeight (@bernsteinWeight n) r < M := + lt_of_le_of_ne hr hrM + have hprod : + presentedPBWBasis k n m * presentedPBWBasis k n r ∈ + bernsteinPiece k n + (monomialWeight (@bernsteinWeight n) m + + monomialWeight (@bernsteinWeight n) r) := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + simpa [phaseExponent_split] using + presentedOrderedMonomial_mul_mem_bernsteinPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + have hlt : + monomialWeight (@bernsteinWeight n) m + + monomialWeight (@bernsteinWeight n) r < N + M := by + omega + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@bernsteinWeight n) _ hprod hlt, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp [hrM] + · have hmlt : monomialWeight (@bernsteinWeight n) m < N := + lt_of_le_of_ne hm hmN + have hprod : + presentedPBWBasis k n m * presentedPBWBasis k n r ∈ + bernsteinPiece k n + (monomialWeight (@bernsteinWeight n) m + + monomialWeight (@bernsteinWeight n) r) := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + simpa [phaseExponent_split] using + presentedOrderedMonomial_mul_mem_bernsteinPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + have hlt : + monomialWeight (@bernsteinWeight n) m + + monomialWeight (@bernsteinWeight n) r < N + M := by + omega + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@bernsteinWeight n) _ hprod hlt, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp [hmN] + · intro y hy + simp + · intro x hx + simp + · intro x y z hx hy hz hxy hyz + simp only [add_mul, map_add, hxy, hyz] + · intro x y z hx hy hz hxy hxz + simp only [mul_add, map_add, hxy, hxz] + · intro c x y hx hy hxy + simp only [Algebra.smul_mul_assoc, map_smul, hxy] + · intro c x y hx hy hxy + simp only [Algebra.mul_smul_comm, map_smul, hxy] + +theorem presentedPrincipalComponent_mul_order + {n N M : ℕ} {x y : PresentedWeyl k n} + (hx : x ∈ orderPiece k n N) (hy : y ∈ orderPiece k n M) : + presentedPrincipalComponent k (@orderWeight n) (N + M) (x * y) = + presentedPrincipalComponent k (@orderWeight n) N x * + presentedPrincipalComponent k (@orderWeight n) M y := by + rw [orderPiece, presentedWeightPiece_eq_span] at hx hy + apply Submodule.span_induction₂ + (p := fun x y _ _ => + presentedPrincipalComponent k (@orderWeight n) (N + M) (x * y) = + presentedPrincipalComponent k (@orderWeight n) N x * + presentedPrincipalComponent k (@orderWeight n) M y) + (ha := hx) (hb := hy) + · intro bx bz hbx hbz + obtain ⟨m, hm, rfl⟩ := hbx + obtain ⟨r, hr, rfl⟩ := hbz + by_cases hmN : monomialWeight (@orderWeight n) m = N + · by_cases hrM : monomialWeight (@orderWeight n) r = M + · rw [← hmN, ← hrM, + presentedPBWBasis_mul_principal_order, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp + · have hrlt : monomialWeight (@orderWeight n) r < M := + lt_of_le_of_ne hr hrM + have hprod : + presentedPBWBasis k n m * presentedPBWBasis k n r ∈ + orderPiece k n + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) r) := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + simpa [phaseExponent_split] using + presentedOrderedMonomial_mul_mem_orderPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + have hlt : + monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) r < N + M := by + omega + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight n) _ hprod hlt, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp [hrM] + · have hmlt : monomialWeight (@orderWeight n) m < N := + lt_of_le_of_ne hm hmN + have hprod : + presentedPBWBasis k n m * presentedPBWBasis k n r ∈ + orderPiece k n + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) r) := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + simpa [phaseExponent_split] using + presentedOrderedMonomial_mul_mem_orderPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => r (.inl i)) (fun i => r (.inr i)) + have hlt : + monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) r < N + M := by + omega + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight n) _ hprod hlt, + presentedPrincipalComponent_basis, + presentedPrincipalComponent_basis] + simp [hmN] + · intro y hy + simp + · intro x hx + simp + · intro x y z hx hy hz hxy hyz + simp only [add_mul, map_add, hxy, hyz] + · intro x y z hx hy hz hxy hxz + simp only [mul_add, map_add, hxy, hxz] + · intro c x y hx hy hxy + simp only [Algebra.smul_mul_assoc, map_smul, hxy] + · intro c x y hx hy hxy + simp only [Algebra.mul_smul_comm, map_smul, hxy] + + +end + +end Stafford38.WeylLeadingSymbol diff --git a/LeanPool/Stafford38/Stafford38/Weyl/MonicNormalization.lean b/LeanPool/Stafford38/Stafford38/Weyl/MonicNormalization.lean new file mode 100644 index 0000000000..45f81e49c6 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/MonicNormalization.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.SymplecticCompletion +import LeanPool.Stafford38.Stafford38.Weyl.SymbolCompatibility + +/-! +# Bernstein-top selection and scalar monic normalization + +The checked PBW normal form selects the actual top Bernstein degree of every +nonzero presented Weyl element. Degree zero is exactly the scalar case. In +positive degree, the explicit symplectic chart is applied and the transformed +operator is scaled by the inverse of its nonzero pure-power coefficient. The +normalized principal axis coefficient is then exactly one. + +This file stops at the commutative-symbol monicity interface. Identifying it +with a monic Ore polynomial in the selected momentum is the next dependency. +-/ + +namespace Stafford38.WeylMonicNormalization + +open Stafford38.Characteristic +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.CharacteristicSymplecticCompletion +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylSymplectic +open Stafford38.WeylSymbolCompatibility + +noncomputable section +universe u +variable (k : Type u) [Field k] + +theorem weightedHomogeneousComponent_weightedTotalDegree_ne_zero + {σ : Type*} [DecidableEq σ] (w : σ → ℕ) + {f : MvPolynomial σ k} (hf : f ≠ 0) : + MvPolynomial.weightedHomogeneousComponent w + (MvPolynomial.weightedTotalDegree w f) f ≠ 0 := by + have hs : f.support.Nonempty := MvPolynomial.support_nonempty.mpr hf + rcases Finset.exists_mem_eq_sup f.support hs (Finsupp.weight w) with + ⟨m, hm, hmax⟩ + intro hzero + have hc := congrArg (MvPolynomial.coeff m) hzero + rw [MvPolynomial.coeff_weightedHomogeneousComponent] at hc + have hw : Finsupp.weight w m = MvPolynomial.weightedTotalDegree w f := by + simpa [MvPolynomial.weightedTotalDegree] using hmax.symm + rw [if_pos hw] at hc + exact (MvPolynomial.mem_support_iff.mp hm) hc + +theorem principal_isHomogeneous {n N : ℕ} (d : PresentedWeyl k n) : + (presentedPrincipalComponent k (@bernsteinWeight n) N d).IsHomogeneous N := by + change MvPolynomial.IsWeightedHomogeneous (1 : PhaseVar n → ℕ) + (presentedPrincipalComponent k (@bernsteinWeight n) N d) N + have hweight : (@bernsteinWeight n) = (1 : PhaseVar n → ℕ) := by + funext i + rfl + rw [← hweight] + simpa [presentedPrincipalComponent] using + (MvPolynomial.weightedHomogeneousComponent_isWeightedHomogeneous + (w := @bernsteinWeight n) (n := N) + (φ := presentedNormalFormLinearEquiv k n d)) + +theorem exists_top_bernstein_piece {n : ℕ} {d : PresentedWeyl k n} + (hd : d ≠ 0) : + ∃ N : ℕ, d ∈ bernsteinPiece k n N ∧ + presentedPrincipalComponent k (@bernsteinWeight n) N d ≠ 0 := by + let f := presentedNormalFormLinearEquiv k n d + have hf : f ≠ 0 := by + intro hzero + apply hd + apply (presentedNormalFormLinearEquiv k n).injective + simpa [f] using hzero + let N := MvPolynomial.weightedTotalDegree (@bernsteinWeight n) f + refine ⟨N, ?_, ?_⟩ + · change d ∈ presentedWeightPiece k (@bernsteinWeight n) N + rw [mem_presentedWeightPiece] + intro m hm + simpa [f, N, monomialWeight, Finsupp.weight_apply, smul_eq_mul] using + MvPolynomial.le_weightedTotalDegree (@bernsteinWeight n) + (MvPolynomial.mem_support_iff.mpr hm) + · exact weightedHomogeneousComponent_weightedTotalDegree_ne_zero k + (@bernsteinWeight n) hf + +theorem eq_algebraMap_of_mem_bernsteinPiece_zero {n : ℕ} + {d : PresentedWeyl k n} (hd : d ∈ bernsteinPiece k n 0) : + ∃ c : k, d = algebraMap k (PresentedWeyl k n) c := by + let f := presentedNormalFormLinearEquiv k n d + let c := MvPolynomial.coeff 0 f + have hf : f = MvPolynomial.C c := by + ext m + by_cases hm : m = 0 + · subst m + simp [c] + · have hcoeff : MvPolynomial.coeff m f = 0 := by + by_contra hne + have hle := (mem_presentedWeightPiece k (@bernsteinWeight n) 0 d).mp hd m hne + have hdeg : m.degree = 0 := by + apply Nat.eq_zero_of_le_zero + rw [Finsupp.degree_eq_weight_one] + simpa [f, monomialWeight, bernsteinWeight, + Finsupp.weight_apply, smul_eq_mul] using hle + exact hm ((Finsupp.degree_eq_zero_iff m).mp hdeg) + rw [hcoeff] + simp [Ne.symm hm] + refine ⟨c, ?_⟩ + apply (presentedNormalFormLinearEquiv k n).injective + rw [show presentedNormalFormLinearEquiv k n d = f by rfl, hf] + rw [← mul_one ((algebraMap k (PresentedWeyl k n)) c), + ← Algebra.smul_def] + change MvPolynomial.C c = + presentedNormalFormLinearEquiv k n (c • (1 : PresentedWeyl k n)) + rw [map_smul, presentedNormalFormLinearEquiv_one] + exact MvPolynomial.C_eq_smul_one + +theorem scalar_or_positive_top_bernstein_piece {n : ℕ} + {d : PresentedWeyl k n} (hd : d ≠ 0) : + (∃ c : k, c ≠ 0 ∧ d = algebraMap k (PresentedWeyl k n) c) ∨ + ∃ N : ℕ, 0 < N ∧ d ∈ bernsteinPiece k n N ∧ + presentedPrincipalComponent k (@bernsteinWeight n) N d ≠ 0 := by + rcases exists_top_bernstein_piece k hd with ⟨N, hpiece, hprincipal⟩ + by_cases hN : N = 0 + · subst N + left + rcases eq_algebraMap_of_mem_bernsteinPiece_zero k hpiece with ⟨c, hdc⟩ + refine ⟨c, ?_, hdc⟩ + intro hc + subst c + simp at hdc + exact hd hdc + · right + exact ⟨N, Nat.pos_of_ne_zero hN, hpiece, hprincipal⟩ + +def normalizedSymplecticImage {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (c : k) (d : PresentedWeyl k n) : PresentedWeyl k n := + c⁻¹ • standardSymplecticAlgHom k M hM d + +def HasNormalizedSymplecticChart {n : ℕ} (t : PhaseVar n) (N : ℕ) + (d : PresentedWeyl k n) : Prop := + ∃ (M Ninv : Matrix (PhaseVar n) (PhaseVar n) k) (c : k), + ∃ hM : M * standardForm k n * Matrix.transpose M = standardForm k n, + Ninv * standardForm k n * Matrix.transpose Ninv = standardForm k n ∧ + M * Ninv = 1 ∧ Ninv * M = 1 ∧ c ≠ 0 ∧ + normalizedSymplecticImage k M hM c d ∈ bernsteinPiece k n N ∧ + MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (presentedPrincipalComponent k (@bernsteinWeight n) N + (normalizedSymplecticImage k M hM c d))) = 1 + +theorem exists_normalized_symplectic_image [CharZero k] + {n N : ℕ} (t : PhaseVar n) {d : PresentedWeyl k n} + (hd : d ∈ bernsteinPiece k n N) + (hP : (presentedPrincipalComponent k (@bernsteinWeight n) N d).IsHomogeneous N) + (hPne : presentedPrincipalComponent k (@bernsteinWeight n) N d ≠ 0) + (hN : 0 < N) : + HasNormalizedSymplecticChart k t N d := by + rcases exists_symplectic_chart_matrices k t hP hPne hN with + ⟨M, Ninv, hM, hNinv, hMN, hNM, hc⟩ + let c : k := MvPolynomial.coeff (Finsupp.single () N) + (axisPolynomial k t + (Stafford38.CharacteristicLinearAction.symbolLinearAlgHom k M + (presentedPrincipalComponent k (@bernsteinWeight n) N d))) + have hc' : c ≠ 0 := hc + refine ⟨M, Ninv, c, hM, hNinv, hMN, hNM, hc', ?_, ?_⟩ + · exact (bernsteinPiece k n N).smul_mem _ + (standardSymplecticAlgHom_preserves_bernsteinPiece k M hM hd) + · rw [normalizedSymplecticImage, map_smul] + rw [standardSymplecticAlgHom_principal_compatibility k M hM hd] + simp only [map_smul, MvPolynomial.coeff_smul] + change c⁻¹ * c = 1 + exact inv_mul_cancel₀ hc' + +theorem scalar_or_normalized_symplectic_image [CharZero k] + {n : ℕ} (hn : 0 < n) {d : PresentedWeyl k n} (hd : d ≠ 0) : + (∃ c : k, c ≠ 0 ∧ d = algebraMap k (PresentedWeyl k n) c) ∨ + ∃ N : ℕ, 0 < N ∧ + HasNormalizedSymplecticChart k (.inr ⟨0, hn⟩) N d := by + rcases scalar_or_positive_top_bernstein_piece k hd with hscalar | htop + · exact Or.inl hscalar + · rcases htop with ⟨N, hN, hpiece, hprincipal⟩ + right + refine ⟨N, hN, ?_⟩ + exact exists_normalized_symplectic_image k (.inr ⟨0, hn⟩) hpiece + (principal_isHomogeneous k d) hprincipal hN + +/- Exact statement pins for top-degree selection and the scalar/normalized +chart dichotomy. -/ +theorem top_bernstein_piece_statement {n : ℕ} {d : PresentedWeyl k n} + (hd : d ≠ 0) : + ∃ N : ℕ, d ∈ bernsteinPiece k n N ∧ + presentedPrincipalComponent k (@bernsteinWeight n) N d ≠ 0 := + exists_top_bernstein_piece k hd + +theorem scalar_or_normalized_chart_statement [CharZero k] + {n : ℕ} (hn : 0 < n) {d : PresentedWeyl k n} (hd : d ≠ 0) : + (∃ c : k, c ≠ 0 ∧ d = algebraMap k (PresentedWeyl k n) c) ∨ + ∃ N : ℕ, 0 < N ∧ + HasNormalizedSymplecticChart k (.inr ⟨0, hn⟩) N d := + scalar_or_normalized_symplectic_image k hn hd + + +end +end Stafford38.WeylMonicNormalization diff --git a/LeanPool/Stafford38/Stafford38/Weyl/OrderRees.lean b/LeanPool/Stafford38/Stafford38/Weyl/OrderRees.lean new file mode 100644 index 0000000000..bed1e9adb0 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/OrderRees.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Characteristic.AssociatedGradedModule +import Mathlib.Algebra.Polynomial.Coeff + +/-! +# The differential-order Rees ring + +This file constructs the literal Rees ring of the differential-order +filtration as the subring of the central polynomial ring `A[T]` whose +degree-`N` coefficient lies in `F_N A`. No commutativity of `A`, Rees +specialization, or Gabber theorem is assumed. +-/ + +namespace Stafford38.WeylOrderRees + +open Stafford38.CharacteristicAssociatedGradedModule +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] +variable {n : ℕ} + +/-- The differential-order Rees ring inside the central polynomial ring over +the presented Weyl algebra. -/ +def orderReesSubring : Subring (Polynomial (PresentedWeyl k n)) where + carrier := {f | ∀ N, f.coeff N ∈ orderPiece k n N} + zero_mem' := by simp + one_mem' := by + intro N + by_cases hN : N = 0 + · subst N + rw [Polynomial.coeff_one, if_pos rfl] + exact (orderPieceOne (n := n) k).property + · rw [Polynomial.coeff_one, if_neg hN] + exact Submodule.zero_mem _ + add_mem' := by + intro f g hf hg N + rw [Polynomial.coeff_add] + exact Submodule.add_mem _ (hf N) (hg N) + neg_mem' := by + intro f hf N + rw [Polynomial.coeff_neg] + exact Submodule.neg_mem _ (hf N) + mul_mem' := by + intro f g hf hg N + rw [Polynomial.coeff_mul] + apply Submodule.sum_mem + intro ij hij + have hmul := mul_mem_orderPiece k (hf ij.1) (hg ij.2) + have hij' : ij.1 + ij.2 = N := Finset.HasAntidiagonal.mem_antidiagonal.mp hij + simpa [hij'] using hmul + +/-- The type of elements of the differential-order Rees ring. -/ +abbrev OrderReesRing := orderReesSubring (n := n) k + +@[simp] theorem mem_orderReesSubring_iff + (f : Polynomial (PresentedWeyl k n)) : + f ∈ orderReesSubring (n := n) k ↔ + ∀ N, f.coeff N ∈ orderPiece k n N := + Iff.rfl + +/-- A filtered operator inserted in its declared Rees degree. -/ +def orderReesMonomial (N : ℕ) (z : orderPiece k n N) : + OrderReesRing (n := n) k := + ⟨Polynomial.monomial N (z : PresentedWeyl k n), by + intro M + rw [Polynomial.coeff_monomial] + split_ifs with h + · subst M + exact z.property + · exact Submodule.zero_mem _⟩ + +@[simp] theorem orderReesMonomial_coe (N : ℕ) (z : orderPiece k n N) : + ((orderReesMonomial k N z : OrderReesRing (n := n) k) : + Polynomial (PresentedWeyl k n)) = + Polynomial.monomial N (z : PresentedWeyl k n) := + rfl + +@[simp] theorem orderReesMonomial_coeff_same + (N : ℕ) (z : orderPiece k n N) : + ((orderReesMonomial k N z : OrderReesRing (n := n) k) : + Polynomial (PresentedWeyl k n)).coeff N = (z : PresentedWeyl k n) := by + simp + +/-- The central Rees parameter `T`, represented in degree one by the unit +operator. -/ +def orderReesParameter : OrderReesRing (n := n) k := + orderReesMonomial k 1 + ⟨1, presentedWeightPiece_mono k orderWeight (Nat.zero_le 1) + (orderPieceOne (n := n) k).property⟩ + +@[simp] theorem orderReesParameter_coe : + ((orderReesParameter (n := n) k : OrderReesRing (n := n) k) : + Polynomial (PresentedWeyl k n)) = Polynomial.X := by + rw [orderReesParameter, orderReesMonomial_coe] + exact Polynomial.monomial_one_one_eq_X + +/-- Multiplication of homogeneous Rees representatives is multiplication in +the Weyl algebra, with degrees added. -/ +theorem orderReesMonomial_mul + {N M : ℕ} (z : orderPiece k n N) (y : orderPiece k n M) : + orderReesMonomial k N z * orderReesMonomial k M y = + orderReesMonomial k (N + M) + ⟨(z : PresentedWeyl k n) * (y : PresentedWeyl k n), + mul_mem_orderPiece k z.property y.property⟩ := by + apply Subtype.ext + simp [orderReesMonomial, Polynomial.monomial_mul_monomial] + +/-- Multiplication by the Rees parameter raises the declared degree and keeps +the underlying Weyl operator unchanged. -/ +theorem orderReesParameter_mul_monomial + {N : ℕ} (z : orderPiece k n N) : + orderReesParameter (n := n) k * orderReesMonomial k N z = + orderReesMonomial k (N + 1) + ⟨(z : PresentedWeyl k n), + presentedWeightPiece_mono k orderWeight (Nat.le_succ N) z.property⟩ := by + apply Subtype.ext + simp [orderReesParameter_coe, orderReesMonomial, + Polynomial.X_mul_monomial, Nat.add_comm] + +/-- The polynomial Rees parameter is central, including over the +noncommutative Weyl coefficient ring. -/ +theorem orderReesParameter_mul_comm + (r : OrderReesRing (n := n) k) : + orderReesParameter (n := n) k * r = + r * orderReesParameter (n := n) k := by + apply Subtype.ext + change Polynomial.X * (r : Polynomial (PresentedWeyl k n)) = + (r : Polynomial (PresentedWeyl k n)) * Polynomial.X + exact Polynomial.X_mul + +/-- A homogeneous class in positive Rees degree is divisible by the Rees +parameter exactly when its coefficient already lies one filtration step +lower. This is the degreewise kernel statement behind specialization at +`T = 0`. -/ +theorem exists_parameter_mul_eq_monomial_iff_mem_lower + {N : ℕ} (z : orderPiece k n (N + 1)) : + (∃ r : OrderReesRing (n := n) k, + orderReesParameter (n := n) k * r = + orderReesMonomial k (N + 1) z) ↔ + (z : PresentedWeyl k n) ∈ orderPiece k n N := by + constructor + · rintro ⟨r, hr⟩ + have hc := congrArg + (fun p : Polynomial (PresentedWeyl k n) => p.coeff (N + 1)) + (congrArg Subtype.val hr) + change (Polynomial.X * (r : Polynomial (PresentedWeyl k n))).coeff + (N + 1) = + (Polynomial.monomial (N + 1) (z : PresentedWeyl k n)).coeff + (N + 1) at hc + rw [Polynomial.coeff_X_mul, Polynomial.coeff_monomial, if_pos rfl] at hc + rw [← hc] + exact r.property N + · intro hz + let zLower : orderPiece k n N := ⟨z, hz⟩ + refine ⟨orderReesMonomial k N zLower, ?_⟩ + rw [orderReesParameter_mul_monomial] + +/-- In Rees degree zero, a homogeneous representative is a parameter multiple +only when it is zero. -/ +theorem exists_parameter_mul_eq_degreeZero_iff + (z : orderPiece k n 0) : + (∃ r : OrderReesRing (n := n) k, + orderReesParameter (n := n) k * r = orderReesMonomial k 0 z) ↔ + (z : PresentedWeyl k n) = 0 := by + constructor + · rintro ⟨r, hr⟩ + have hc := congrArg + (fun p : Polynomial (PresentedWeyl k n) => p.coeff 0) + (congrArg Subtype.val hr) + change (Polynomial.X * (r : Polynomial (PresentedWeyl k n))).coeff 0 = + (Polynomial.monomial 0 (z : PresentedWeyl k n)).coeff 0 at hc + simpa using hc.symm + · intro hz + have hz' : z = 0 := Subtype.ext hz + subst z + refine ⟨0, ?_⟩ + apply Subtype.ext + simp [orderReesMonomial] + + +end + +end Stafford38.WeylOrderRees diff --git a/LeanPool/Stafford38/Stafford38/Weyl/OuterOreMonic.lean b/LeanPool/Stafford38/Stafford38/Weyl/OuterOreMonic.lean new file mode 100644 index 0000000000..b57bcf2ecd --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/OuterOreMonic.lean @@ -0,0 +1,356 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge + +/-! +# PBW monicity as concrete outer-Ore monicity + +The successor-rank iterated Weyl tower is an outer Ore extension in the newest +momentum. This file exposes its concrete coefficient-left polynomial, proves +the exact coefficient formula relating the nested PBW normal form to that +polynomial, and turns the checked PBW coefficient-one bound into +`Polynomial.Monic`. +-/ + +namespace Stafford38.WeylOuterOreMonic + +open AlgebraicAnalysis.OreDivision +open Stafford38.Characteristic +open AlgebraicAnalysis.OreAssociativity +open Stafford38.OreCoordinateStage +open Stafford38.OreIteratedPairStage +open Stafford38.OrePairStage +open Stafford38.OreLinearNormalForm +open Stafford38.OreScalarAlgebra +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBW +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylFiltration + +noncomputable section +universe u +variable (k : Type u) [Field k] + +local instance (n : ℕ) : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + +local instance (n : ℕ) : + Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + +local instance (n : ℕ) : + Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + +def presentedOuterPolynomial (n : ℕ) (d : PresentedWeyl k (n + 1)) : + Polynomial (CoordinateStage (B := IteratedPairStage k n)) := + (normalFormAddEquiv + (coordinateDerivation : + AlgebraicAnalysis.OreDivisionDerivation + (CoordinateStage (B := IteratedPairStage k n)))).symm + (presentedToIterated k (n + 1) d) + +def coordinateCoefficientNormalForm (n : ℕ) : + CoordinateStage (B := IteratedPairStage k n) ≃ₗ[k] + Polynomial (SymbolRing k n) := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + exact (normalFormLinearEquiv zeroDerivation + (normalOreAlgebra_algebraMap zeroDerivation (fun c => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c)))).symm.trans + (polynomialMapRangeLinearEquiv (iteratedNormalFormLinearEquiv k n)) + +def presentedNestedNormalForm (n : ℕ) (d : PresentedWeyl k (n + 1)) : + Polynomial (Polynomial (SymbolRing k n)) := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + exact pairNormalFormLinearEquiv + (normalOreAlgebra_algebraMap zeroDerivation (fun c => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c))) + (normalOreAlgebra_algebraMap coordinateDerivation + coordinateDerivation_algebraMap) + (iteratedNormalFormLinearEquiv k n) + (presentedToIterated k (n + 1) d) + +theorem flatten_presentedNestedNormalForm (n : ℕ) + (d : PresentedWeyl k (n + 1)) : + flattenPairSymbols k n (presentedNestedNormalForm k n d) = + presentedNormalFormLinearEquiv k (n + 1) d := by + rfl + +theorem presentedNestedNormalForm_eq_mapRange (n : ℕ) + (d : PresentedWeyl k (n + 1)) : + presentedNestedNormalForm k n d = + polynomialMapRangeLinearEquiv (coordinateCoefficientNormalForm k n) + (presentedOuterPolynomial k n d) := by + rfl + +def pairExponent (n a p : ℕ) (m : PhaseVar n →₀ ℕ) : + PhaseVar (n + 1) →₀ ℕ := + Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a + + Finsupp.mapDomain oldIndex m + +@[simp] theorem mapDomain_oldIndex_newCoordinate (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex m (.inl (0 : Fin (n + 1))) = 0 := by + rw [Finsupp.mapDomain_of_notMem_range] + rintro ⟨i, hi⟩ + cases i with + | inl j => exact Fin.succ_ne_zero j (Sum.inl.inj hi) + | inr j => simp [oldIndex] at hi + +@[simp] theorem mapDomain_oldIndex_newMomentum (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex m (.inr (0 : Fin (n + 1))) = 0 := by + rw [Finsupp.mapDomain_of_notMem_range] + rintro ⟨i, hi⟩ + cases i with + | inl j => simp [oldIndex] at hi + | inr j => exact Fin.succ_ne_zero j (Sum.inr.inj hi) + +theorem coeff_flattenPairSymbols_monomial (n a p a' p' : ℕ) + (m : PhaseVar n →₀ ℕ) (r : SymbolRing k n) : + MvPolynomial.coeff (pairExponent n a p m) + (flattenPairSymbols k n + (Polynomial.monomial p' (Polynomial.monomial a' r))) = + if p' = p ∧ a' = a then MvPolynomial.coeff m r else 0 := by + rw [flattenPairSymbols_monomial] + rw [MvPolynomial.X_pow_eq_monomial, MvPolynomial.X_pow_eq_monomial, + MvPolynomial.monomial_mul, mul_one] + rw [MvPolynomial.coeff_monomial_mul'] + classical + by_cases hp : p' = p + · subst p' + by_cases ha : a' = a + · subst a' + have hle : + (Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a) ≤ + pairExponent n a p m := by + intro i + simp only [pairExponent, Finsupp.add_apply] + omega + rw [if_pos hle] + have hsub : + (pairExponent n a p m - + (Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a)) = + Finsupp.mapDomain oldIndex m := by + rw [pairExponent] + exact add_tsub_cancel_left _ _ + rw [hsub, MvPolynomial.coeff_rename_mapDomain oldIndex oldIndex_injective] + simp + · by_cases hle : + ((Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a') ≤ + pairExponent n a p m) + · rw [if_pos hle] + have haa : a' ≤ a := by + simpa [pairExponent, Finsupp.single_apply] using + hle (.inl (0 : Fin (n + 1))) + have hz : MvPolynomial.coeff + ((pairExponent n a p m) - + (Finsupp.single (.inr (0 : Fin (n + 1))) p + + Finsupp.single (.inl (0 : Fin (n + 1))) a')) + (MvPolynomial.rename oldIndex r) = 0 := by + apply MvPolynomial.coeff_rename_eq_zero + intro u hu + have hnew := DFunLike.congr_fun hu (.inl (0 : Fin (n + 1))) + simp [pairExponent] at hnew + omega + rw [hz] + simp [ha] + · rw [if_neg hle] + simp [ha] + · by_cases hle : + ((Finsupp.single (.inr (0 : Fin (n + 1))) p' + + Finsupp.single (.inl (0 : Fin (n + 1))) a') ≤ + pairExponent n a p m) + · rw [if_pos hle] + have hpp : p' ≤ p := by + simpa [pairExponent, Finsupp.single_apply] using + hle (.inr (0 : Fin (n + 1))) + have hz : MvPolynomial.coeff + ((pairExponent n a p m) - + (Finsupp.single (.inr (0 : Fin (n + 1))) p' + + Finsupp.single (.inl (0 : Fin (n + 1))) a')) + (MvPolynomial.rename oldIndex r) = 0 := by + apply MvPolynomial.coeff_rename_eq_zero + intro u hu + have hnew := DFunLike.congr_fun hu (.inr (0 : Fin (n + 1))) + simp [pairExponent] at hnew + omega + rw [hz] + simp [hp] + · rw [if_neg hle] + simp [hp] + +theorem coeff_flattenPairSymbols (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) + (q : Polynomial (Polynomial (SymbolRing k n))) : + MvPolynomial.coeff (pairExponent n a p m) + (flattenPairSymbols k n q) = + MvPolynomial.coeff m ((q.coeff p).coeff a) := by + induction q using Polynomial.induction_on' with + | add q₁ q₂ h₁ h₂ => simp [map_add, h₁, h₂] + | monomial p' r => + induction r using Polynomial.induction_on' with + | add r₁ r₂ h₁ h₂ => + rw [map_add (Polynomial.monomial p') r₁ r₂] + simp only [map_add, MvPolynomial.coeff_add, + Polynomial.coeff_monomial, Polynomial.coeff_add] + by_cases hp : p' = p + · subst p' + simp [h₁, h₂] + · rw [h₁, h₂] + simp [Polynomial.coeff_monomial, hp] + | monomial a' s => + rw [coeff_flattenPairSymbols_monomial] + simp only [Polynomial.coeff_monomial] + by_cases hp : p' = p + · subst p' + by_cases ha : a' = a + · subst a' + simp + · simp [Polynomial.coeff_monomial, ha] + · simp [hp] + +theorem coeff_polynomialMapRangeLinearEquiv + {R S : Type*} [Semiring R] [Semiring S] + [Algebra k R] [Algebra k S] (e : R ≃ₗ[k] S) + (q : Polynomial R) (p : ℕ) : + (polynomialMapRangeLinearEquiv e q).coeff p = e (q.coeff p) := by + induction q using Polynomial.induction_on' with + | add q₁ q₂ h₁ h₂ => simp [map_add, h₁, h₂] + | monomial n r => + rw [polynomialMapRangeLinearEquiv_monomial] + by_cases h : n = p <;> simp [Polynomial.coeff_monomial, h] + +@[simp] theorem degree_pairExponent (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) : + (pairExponent n a p m).degree = + p + a + (Finsupp.mapDomain oldIndex m).degree := by + simp [pairExponent] + +@[simp] theorem pairExponent_newMomentum (n a p : ℕ) + (m : PhaseVar n →₀ ℕ) : + pairExponent n a p m (.inr (0 : Fin (n + 1))) = p := by + simp [pairExponent] + +theorem nested_coeff_eq_zero_of_outer_exponent_gt (n N : ℕ) + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p : ℕ} (hp : N < p) : + (presentedNestedNormalForm k n d).coeff p = 0 := by + ext a m + simp only [Polynomial.coeff_zero, MvPolynomial.coeff_zero] + rw [← coeff_flattenPairSymbols k n a p m] + rw [flatten_presentedNestedNormalForm] + exact coeff_normalForm_eq_zero_of_exponent_gt k + (t := .inr (0 : Fin (n + 1))) (m := pairExponent n a p m) + hd.1 (by simpa using hp) + +theorem nested_coeff_eq_one_at_bound (n N : ℕ) + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (presentedNestedNormalForm k n d).coeff N = 1 := by + ext a m + rw [← coeff_flattenPairSymbols k n a N m] + rw [flatten_presentedNestedNormalForm] + by_cases ha : a = 0 + · subst a + by_cases hm : m = 0 + · subst m + simpa [pairExponent] using hd.2 + · have hmap : Finsupp.mapDomain oldIndex m ≠ 0 := by + exact (Finsupp.mapDomain_injective oldIndex_injective).ne hm + have hdegree : N < (pairExponent n 0 N m).degree := by + rw [degree_pairExponent] + have hpos : 0 < (Finsupp.mapDomain oldIndex m).degree := by + exact Nat.pos_of_ne_zero + ((Finsupp.degree_eq_zero_iff _).not.mpr hmap) + omega + have hz : MvPolynomial.coeff (pairExponent n 0 N m) + (presentedNormalFormLinearEquiv k (n + 1) d) = 0 := by + by_contra hc + have hle := (mem_presentedWeightPiece k (@bernsteinWeight (n + 1)) N d).mp + hd.1 (pairExponent n 0 N m) hc + have : (pairExponent n 0 N m).degree ≤ N := by + change (pairExponent n 0 N m).sum (fun _ e => e) ≤ N + simpa [monomialWeight, bernsteinWeight] using hle + omega + rw [hz] + simp [Polynomial.coeff_one, MvPolynomial.coeff_one, Ne.symm hm] + · have hdegree : N < (pairExponent n a N m).degree := by + rw [degree_pairExponent] + omega + have hz : MvPolynomial.coeff (pairExponent n a N m) + (presentedNormalFormLinearEquiv k (n + 1) d) = 0 := by + by_contra hc + have hle := (mem_presentedWeightPiece k (@bernsteinWeight (n + 1)) N d).mp + hd.1 (pairExponent n a N m) hc + have : (pairExponent n a N m).degree ≤ N := by + change (pairExponent n a N m).sum (fun _ e => e) ≤ N + simpa [monomialWeight, bernsteinWeight] using hle + omega + rw [hz] + simp [Polynomial.coeff_one, ha] + +theorem presentedNestedNormalForm_coeff (n p : ℕ) + (d : PresentedWeyl k (n + 1)) : + (presentedNestedNormalForm k n d).coeff p = + coordinateCoefficientNormalForm k n + ((presentedOuterPolynomial k n d).coeff p) := by + rw [presentedNestedNormalForm_eq_mapRange, + coeff_polynomialMapRangeLinearEquiv] + +theorem coordinateCoefficientNormalForm_one (n : ℕ) : + coordinateCoefficientNormalForm k n 1 = 1 := by + change polynomialMapRangeLinearEquiv (iteratedNormalFormLinearEquiv k n) + ((normalFormLinearEquiv zeroDerivation _).symm 1) = 1 + rw [normalFormLinearEquiv_symm_one] + exact polynomialMapRangeLinearEquiv_one _ (iteratedNormalFormLinearEquiv_one k n) + +theorem outer_coeff_eq_one_at_bound (n N : ℕ) + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (presentedOuterPolynomial k n d).coeff N = 1 := by + have h := nested_coeff_eq_one_at_bound k n N hd + rw [presentedNestedNormalForm_coeff] at h + apply (coordinateCoefficientNormalForm k n).injective + rw [h, coordinateCoefficientNormalForm_one] + +theorem outer_coeff_eq_zero_of_exponent_gt (n N : ℕ) + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) + {p : ℕ} (hp : N < p) : + (presentedOuterPolynomial k n d).coeff p = 0 := by + have h := nested_coeff_eq_zero_of_outer_exponent_gt k n N hd hp + rw [presentedNestedNormalForm_coeff] at h + apply (coordinateCoefficientNormalForm k n).injective + exact h.trans (LinearMap.map_zero (coordinateCoefficientNormalForm k n).toLinearMap).symm + +theorem presentedOuterPolynomial_monic (n N : ℕ) + {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + (presentedOuterPolynomial k n d).Monic := by + apply Polynomial.monic_of_degree_le N + · rw [Polynomial.degree_le_iff_coeff_zero] + intro p hp + exact outer_coeff_eq_zero_of_exponent_gt k n N hd (by simpa using hp) + · exact outer_coeff_eq_one_at_bound k n N hd + +/- Exact declaration and trust-boundary report. -/ + +end +end Stafford38.WeylOuterOreMonic diff --git a/LeanPool/Stafford38/Stafford38/Weyl/PBW.lean b/LeanPool/Stafford38/Stafford38/Weyl/PBW.lean new file mode 100644 index 0000000000..24081182c4 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/PBW.lean @@ -0,0 +1,703 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence +import LeanPool.Stafford38.Stafford38.Ore.LinearNormalForm +import LeanPool.Stafford38.Stafford38.Characteristic.Polynomial +import Mathlib.LinearAlgebra.Basis.Basic + +/-! +# Ordered PBW basis from Ore normal forms + +The checked iterated Ore normal form gives a scalar-linear equivalence with +the commutative polynomial symbol space. Transport across the independently +proved presented/iterated algebra equivalence yields a free-module basis +indexed by commutative monomials, without using monomial independence in the +quotient presentation. Recursive all-degree formulas identify those basis +vectors with ordered products of the named Weyl generators. +-/ + +namespace Stafford38.WeylPBW + +open Stafford +open AlgebraicAnalysis +open AlgebraicAnalysis.OreDivision +open Stafford38.Characteristic +open AlgebraicAnalysis.OreAssociativity +open Stafford38.OreCoordinateStage +open Stafford38.OreIteratedPairStage +open Stafford38.OreLinearNormalForm +open Stafford38.OrePairStage +open Stafford38.OreScalarAlgebra +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +/-- Reindex the two newest symbol variables followed by the old variables to +the standard newest-first coordinate/momentum indexing. -/ +def phaseSuccEquiv (n : Nat) : + ((PUnit.{1} ⊕ PUnit.{1}) ⊕ PhaseVar n) ≃ PhaseVar (n + 1) where + toFun + | .inl (.inl _) => .inr 0 + | .inl (.inr _) => .inl 0 + | .inr (.inl i) => .inl i.succ + | .inr (.inr i) => .inr i.succ + invFun + | .inl i => Fin.cases (.inl (.inr PUnit.unit)) + (fun j => .inr (.inl j)) i + | .inr i => Fin.cases (.inl (.inl PUnit.unit)) + (fun j => .inr (.inr j)) i + left_inv x := by + rcases x with (⟨⟨u⟩ | ⟨u⟩⟩ | ⟨i | i⟩) <;> rfl + right_inv x := by + rcases x with (i | i) + · exact Fin.cases rfl (fun _ => rfl) i + · exact Fin.cases rfl (fun _ => rfl) i + +@[simp] theorem phaseSuccEquiv_old (n : Nat) (i : PhaseVar n) : + phaseSuccEquiv n (.inr i) = oldIndex i := by + cases i <;> rfl + +/-- Flatten the two new univariate normal-form layers and the old symbol +coefficients into the standard rank-successor symbol ring. -/ +def flattenPairSymbols (n : Nat) : + Polynomial (Polynomial (SymbolRing k n)) ≃ₗ[k] SymbolRing k (n + 1) := + (nestedPolynomialLinearEquiv.{u, u} + (k := k) (R := SymbolRing k n)).trans + ((((MvPolynomial.sumAlgEquiv k (PUnit.{1} ⊕ PUnit.{1}) (PhaseVar n)).symm + ).toLinearEquiv).trans + (MvPolynomial.renameEquiv k (phaseSuccEquiv n)).toLinearEquiv) + +@[simp] theorem flattenPairSymbols_coordinate (n : Nat) : + flattenPairSymbols k n (Polynomial.C Polynomial.X) = + MvPolynomial.X (.inl (0 : Fin (n + 1))) := by + simp [flattenPairSymbols, nestedPolynomialLinearEquiv_coordinate, + MvPolynomial.sumAlgEquiv_symm_X] + rfl + +@[simp] theorem flattenPairSymbols_momentum (n : Nat) : + flattenPairSymbols k n Polynomial.X = + MvPolynomial.X (.inr (0 : Fin (n + 1))) := by + simp [flattenPairSymbols, nestedPolynomialLinearEquiv_momentum, + MvPolynomial.sumAlgEquiv_symm_X] + rfl + +@[simp] theorem flattenPairSymbols_one (n : Nat) : + flattenPairSymbols k n 1 = 1 := by + change flattenPairSymbols k n (Polynomial.C (Polynomial.C 1)) = 1 + rw [flattenPairSymbols, LinearEquiv.trans_apply, + nestedPolynomialLinearEquiv_constant] + simp + +@[simp] theorem flattenPairSymbols_oldGenerator (n : Nat) (i : PhaseVar n) : + flattenPairSymbols k n + (Polynomial.C (Polynomial.C (MvPolynomial.X i))) = + MvPolynomial.X (oldIndex i) := by + simp [flattenPairSymbols, nestedPolynomialLinearEquiv_constant, + MvPolynomial.sumAlgEquiv_symm_C_X] + +theorem iterToSum_C_eq_rename {R S₁ S₂ : Type*} [CommSemiring R] + (r : MvPolynomial S₂ R) : + MvPolynomial.iterToSum R S₁ S₂ (MvPolynomial.C r) = + MvPolynomial.rename Sum.inr r := by + induction r using MvPolynomial.induction_on with + | C c => + simpa only [MvPolynomial.rename_C] using + (MvPolynomial.iterToSum_C_C R S₁ S₂ c) + | add p q hp hq => simp [hp, hq] + | mul_X p i hp => + simp only [map_mul, hp, MvPolynomial.iterToSum_C_X, + MvPolynomial.rename_X] + +private theorem sumAlgEquiv_symm_C_eq_rename + {R S₁ S₂ : Type*} [CommSemiring R] (r : MvPolynomial S₂ R) : + (MvPolynomial.sumAlgEquiv R S₁ S₂).symm (MvPolynomial.C r) = + MvPolynomial.rename Sum.inr r := by + induction r using MvPolynomial.induction_on with + | C c => simp + | add p q hp hq => simp [hp, hq] + | mul_X p i hp => + simp only [map_mul, hp, MvPolynomial.sumAlgEquiv_symm_C_X, + MvPolynomial.rename_X] + +/-- Flattening a nested monomial preserves its two new exponents and embeds +the old symbol polynomial through `oldIndex`. -/ +theorem flattenPairSymbols_monomial (n a p : ℕ) (r : SymbolRing k n) : + flattenPairSymbols k n + (Polynomial.monomial p (Polynomial.monomial a r)) = + MvPolynomial.X (.inr (0 : Fin (n + 1))) ^ p * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ^ a * + MvPolynomial.rename oldIndex r := by + rw [flattenPairSymbols, LinearEquiv.trans_apply, + nestedPolynomialLinearEquiv_monomial] + simp only [LinearEquiv.trans_apply, AlgEquiv.toLinearEquiv_apply, + map_mul, map_pow, MvPolynomial.sumAlgEquiv_symm_X, + sumAlgEquiv_symm_C_eq_rename, + MvPolynomial.renameEquiv_apply, MvPolynomial.rename_X] + rw [MvPolynomial.rename_rename] + have hindex : (⇑(phaseSuccEquiv n) ∘ Sum.inr) = oldIndex := by + funext i + exact phaseSuccEquiv_old n i + rw [hindex] + rfl + +/-- The finite exponent vector with coordinate exponents `a` and momentum +exponents `p`. -/ +def phaseExponent {n : ℕ} (a p : Fin n → ℕ) : PhaseVar n →₀ ℕ := + Finsupp.equivFunOnFinite.symm (Sum.elim a p) + +@[simp] theorem phaseExponent_apply {n : ℕ} (a p : Fin n → ℕ) + (i : PhaseVar n) : phaseExponent a p i = Sum.elim a p i := rfl + +theorem oldIndex_injective {n : ℕ} : + Function.Injective (@oldIndex n) := by + intro i j h + cases i with + | inl i => + cases j with + | inl j => simp [oldIndex] at h; subst j; rfl + | inr j => simp [oldIndex] at h + | inr i => + cases j with + | inl j => simp [oldIndex] at h + | inr j => simp [oldIndex] at h; subst j; rfl + +theorem phaseExponent_succ (n : ℕ) (a p : Fin (n + 1) → ℕ) : + phaseExponent a p = + Finsupp.single (.inr (0 : Fin (n + 1))) (p 0) + + Finsupp.single (.inl (0 : Fin (n + 1))) (a 0) + + Finsupp.mapDomain oldIndex + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) := by + ext i + cases i with + | inl i => + refine Fin.cases ?_ (fun j => ?_) i + · rw [Finsupp.add_apply, Finsupp.add_apply, + Finsupp.mapDomain_notin_range] + · simp [phaseExponent] + · rintro ⟨j, hj⟩ + cases j with + | inl j => exact Fin.succ_ne_zero j (Sum.inl.inj hj) + | inr j => simp [oldIndex] at hj + · change a j.succ = _ + _ + + Finsupp.mapDomain oldIndex + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + (oldIndex (.inl j)) + rw [Finsupp.mapDomain_apply oldIndex_injective] + simp [phaseExponent, oldIndex, Finsupp.single_apply, + Fin.succ_ne_zero] + | inr i => + refine Fin.cases ?_ (fun j => ?_) i + · rw [Finsupp.add_apply, Finsupp.add_apply, + Finsupp.mapDomain_notin_range] + · simp [phaseExponent] + · rintro ⟨j, hj⟩ + cases j with + | inl j => simp [oldIndex] at hj + | inr j => exact Fin.succ_ne_zero j (Sum.inr.inj hj) + · change p j.succ = _ + _ + + Finsupp.mapDomain oldIndex + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + (oldIndex (.inr j)) + rw [Finsupp.mapDomain_apply oldIndex_injective] + simp [phaseExponent, oldIndex, Finsupp.single_apply, + Fin.succ_ne_zero] + +/-- Ordered monomials in the iterated tower: all older pairs occur first, and +within each pair the coordinate power precedes the momentum power. -/ +def iteratedOrderedMonomial : + (n : ℕ) → (Fin n → ℕ) → (Fin n → ℕ) → IteratedPairStage k n + | 0, _, _ => 1 + | n + 1, a, p => + stageEmbedding k n + (iteratedOrderedMonomial n (fun i => a i.succ) (fun i => p i.succ)) * + stageCoordinate k n ^ a 0 * stageMomentum k n ^ p 0 + +theorem symbolMonomial_succ (n : ℕ) (a p : Fin (n + 1) → ℕ) : + MvPolynomial.X (.inr (0 : Fin (n + 1))) ^ p 0 * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ^ a 0 * + MvPolynomial.rename oldIndex + (MvPolynomial.monomial + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) 1) = + MvPolynomial.monomial (phaseExponent a p) (1 : k) := by + rw [MvPolynomial.X_pow_eq_monomial, MvPolynomial.X_pow_eq_monomial, + MvPolynomial.rename_monomial, MvPolynomial.monomial_mul, + MvPolynomial.monomial_mul, mul_one, mul_one, phaseExponent_succ] + +/-- Scalar-linear normal-form coordinates for the recursively iterated Ore +tower. -/ +def iteratedNormalFormLinearEquiv : + (n : Nat) → IteratedPairStage k n ≃ₗ[k] SymbolRing k n + | 0 => (MvPolynomial.isEmptyAlgEquiv k (PhaseVar 0)).symm.toLinearEquiv + | n + 1 => by + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + change PairStage (B := IteratedPairStage k n) ≃ₗ[k] SymbolRing k (n + 1) + exact (pairNormalFormLinearEquiv + (normalOreAlgebra_algebraMap zeroDerivation (fun c => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c))) + (normalOreAlgebra_algebraMap coordinateDerivation + coordinateDerivation_algebraMap) + (iteratedNormalFormLinearEquiv n)).trans (flattenPairSymbols k n) + +@[simp] theorem iteratedNormalFormLinearEquiv_one : + ∀ n : Nat, iteratedNormalFormLinearEquiv k n 1 = 1 := by + intro n + induction n with + | zero => + rfl + | succ n ih => + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + let hInner : algebraMap k (CoordinateStage (B := IteratedPairStage k n)) = + (normalCoefficient zeroDerivation).comp + (algebraMap k (IteratedPairStage k n)) := + normalOreAlgebra_algebraMap zeroDerivation (fun c : k => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c)) + let hOuter : algebraMap k (PairStage (B := IteratedPairStage k n)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := IteratedPairStage k n))) := + normalOreAlgebra_algebraMap coordinateDerivation + (fun c : k => coordinateDerivation_algebraMap + (B := IteratedPairStage k n) c) + rw [iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) 1) = 1 + have hone : (1 : PairStage (B := IteratedPairStage k n)) = + pairCoefficient (B := IteratedPairStage k n) + (1 : IteratedPairStage k n) := by + exact (pairCoefficient (B := IteratedPairStage k n)).map_one.symm + rw [hone, pairNormalFormLinearEquiv_coefficient, ih] + exact flattenPairSymbols_one k n + +/-- The recursive normal-form coordinate map sends each named Weyl generator +to its corresponding commutative symbol variable. -/ +@[simp] theorem iteratedNormalFormLinearEquiv_generator : + ∀ (n : Nat) (i : PhaseVar n), + iteratedNormalFormLinearEquiv k n (iteratedGenerator k n i) = + MvPolynomial.X i := by + intro n + induction n with + | zero => + intro i + exact Sum.elim Fin.elim0 Fin.elim0 i + | succ n ih => + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + let hInner : algebraMap k (CoordinateStage (B := IteratedPairStage k n)) = + (normalCoefficient zeroDerivation).comp + (algebraMap k (IteratedPairStage k n)) := + normalOreAlgebra_algebraMap zeroDerivation (fun c : k => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c)) + let hOuter : algebraMap k (PairStage (B := IteratedPairStage k n)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := IteratedPairStage k n))) := + normalOreAlgebra_algebraMap coordinateDerivation + (fun c : k => coordinateDerivation_algebraMap + (B := IteratedPairStage k n) c) + intro i + cases i with + | inl i => + refine Fin.cases ?_ (fun j => ?_) i + · change iteratedNormalFormLinearEquiv k (n + 1) (stageCoordinate k n) = _ + rw [iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) pairCoordinate) = _ + rw [pairNormalFormLinearEquiv_coordinate _ _ _ + (iteratedNormalFormLinearEquiv_one k n)] + exact flattenPairSymbols_coordinate k n + · change iteratedNormalFormLinearEquiv k (n + 1) + (stageEmbedding k n (iteratedCoordinate k n j)) = _ + rw [iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) + (pairCoefficient (iteratedCoordinate k n j))) = _ + have hij := ih (.inl j) + change iteratedNormalFormLinearEquiv k n (iteratedCoordinate k n j) = + MvPolynomial.X (.inl j) at hij + rw [pairNormalFormLinearEquiv_coefficient, hij, + flattenPairSymbols_oldGenerator] + rfl + + | inr i => + refine Fin.cases ?_ (fun j => ?_) i + · change iteratedNormalFormLinearEquiv k (n + 1) (stageMomentum k n) = _ + rw [iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) pairMomentum) = _ + rw [pairNormalFormLinearEquiv_momentum _ _ _ + (iteratedNormalFormLinearEquiv_one k n)] + exact flattenPairSymbols_momentum k n + · change iteratedNormalFormLinearEquiv k (n + 1) + (stageEmbedding k n (iteratedMomentum k n j)) = _ + rw [iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) + (pairCoefficient (iteratedMomentum k n j))) = _ + have hij := ih (.inr j) + change iteratedNormalFormLinearEquiv k n (iteratedMomentum k n j) = + MvPolynomial.X (.inr j) at hij + rw [pairNormalFormLinearEquiv_coefficient, hij, + flattenPairSymbols_oldGenerator] + rfl + +/-- Every recursively ordered product of the named iterated generators has +exactly the corresponding commutative symbol monomial as its normal form. -/ +theorem iteratedOrderedMonomial_normal : + ∀ (n : ℕ) (a p : Fin n → ℕ), + iteratedNormalFormLinearEquiv k n (iteratedOrderedMonomial k n a p) = + MvPolynomial.monomial (phaseExponent a p) 1 := by + intro n + induction n with + | zero => + intro a p + change 1 = MvPolynomial.monomial (phaseExponent a p) 1 + have hz : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hz] + simp [MvPolynomial.monomial_zero'] + | succ n ih => + letI : Algebra k (IteratedPairStage k n) := + iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := + pairStageAlgebra + let hInner : algebraMap k (CoordinateStage (B := IteratedPairStage k n)) = + (normalCoefficient zeroDerivation).comp + (algebraMap k (IteratedPairStage k n)) := + normalOreAlgebra_algebraMap zeroDerivation (fun c : k => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c)) + let hOuter : algebraMap k (PairStage (B := IteratedPairStage k n)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := IteratedPairStage k n))) := + normalOreAlgebra_algebraMap coordinateDerivation + (fun c : k => coordinateDerivation_algebraMap + (B := IteratedPairStage k n) c) + intro a p + rw [iteratedOrderedMonomial, iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv hInner hOuter + (iteratedNormalFormLinearEquiv k n) + (pairCoefficient (B := IteratedPairStage k n) + (iteratedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + pairCoordinate (B := IteratedPairStage k n) ^ a 0 * + pairMomentum (B := IteratedPairStage k n) ^ p 0)) = _ + rw [pairNormalFormLinearEquiv_orderedMonomial, + ih (fun i => a i.succ) (fun i => p i.succ), + flattenPairSymbols_monomial, symbolMonomial_succ] + +/-- Append powers of the newest coordinate and momentum to an arbitrary old +coefficient in normal order. -/ +def iteratedCoefficientOrdered (n a p : ℕ) (z : IteratedPairStage k n) : + IteratedPairStage k (n + 1) := + stageEmbedding k n z * stageCoordinate k n ^ a * stageMomentum k n ^ p + +/-- Appending a normal-ordered newest pair shifts the old symbol polynomial by +the corresponding two monomial powers. -/ +theorem iteratedNormalFormLinearEquiv_coefficient_ordered + (n a p : ℕ) (z : IteratedPairStage k n) : + iteratedNormalFormLinearEquiv k (n + 1) + (iteratedCoefficientOrdered k n a p z) = + MvPolynomial.X (.inr (0 : Fin (n + 1))) ^ p * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ^ a * + MvPolynomial.rename oldIndex (iteratedNormalFormLinearEquiv k n z) := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := pairStageAlgebra + let hInner : algebraMap k (CoordinateStage (B := IteratedPairStage k n)) = + (normalCoefficient zeroDerivation).comp + (algebraMap k (IteratedPairStage k n)) := + normalOreAlgebra_algebraMap zeroDerivation (fun c : k => by + exact zeroDerivation_apply (algebraMap k (IteratedPairStage k n) c)) + let hOuter : algebraMap k (PairStage (B := IteratedPairStage k n)) = + (normalCoefficient coordinateDerivation).comp + (algebraMap k (CoordinateStage (B := IteratedPairStage k n))) := + normalOreAlgebra_algebraMap coordinateDerivation + (fun c : k => coordinateDerivation_algebraMap + (B := IteratedPairStage k n) c) + rw [iteratedCoefficientOrdered, iteratedNormalFormLinearEquiv] + change flattenPairSymbols k n + (pairNormalFormLinearEquiv (B := IteratedPairStage k n) + hInner hOuter (iteratedNormalFormLinearEquiv k n) + (stageEmbedding k n z * stageCoordinate k n ^ a * + stageMomentum k n ^ p)) = _ + unfold stageEmbedding stageCoordinate stageMomentum + have hpair := pairNormalFormLinearEquiv_orderedMonomial hInner hOuter + (iteratedNormalFormLinearEquiv k n) z a p + have hflat := congrArg (flattenPairSymbols k n) hpair + rw [flattenPairSymbols_monomial] at hflat + exact hflat + +/-- Normal-form coordinates for the quotient presentation, obtained by +transport through the presented/iterated algebra equivalence. -/ +def presentedNormalFormLinearEquiv (n : Nat) : + PresentedWeyl k n ≃ₗ[k] SymbolRing k n := + (presentedIteratedEquiv k n).toLinearEquiv.trans + (iteratedNormalFormLinearEquiv k n) + +@[simp] theorem presentedNormalFormLinearEquiv_one (n : Nat) : + presentedNormalFormLinearEquiv k n 1 = 1 := by + rw [presentedNormalFormLinearEquiv, LinearEquiv.trans_apply, + AlgEquiv.toLinearEquiv_apply, map_one, iteratedNormalFormLinearEquiv_one] + +/-- The transported normal-form coordinates agree with the named generators +of the quotient presentation. -/ +@[simp] theorem presentedNormalFormLinearEquiv_generator (n : Nat) + (i : PhaseVar n) : + presentedNormalFormLinearEquiv k n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = + MvPolynomial.X i := by + rw [presentedNormalFormLinearEquiv, LinearEquiv.trans_apply, + AlgEquiv.toLinearEquiv_apply, presentedIteratedEquiv_generator, + iteratedNormalFormLinearEquiv_generator] + +/-- Append powers of the newest named coordinate and momentum to an arbitrary +old presentation element in normal order. -/ +def presentedCoefficientOrdered (n a p : ℕ) (z : PresentedWeyl k n) : + PresentedWeyl k (n + 1) := + previousWeylEmbedding k n z * presentedCoordinate k n ^ a * + presentedMomentum k n ^ p + +/-- Normal-form coordinates of an arbitrary old presentation element followed +by powers of the newest named coordinate and momentum. -/ +theorem presentedNormalFormLinearEquiv_previous_ordered + (n a p : ℕ) (z : PresentedWeyl k n) : + presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n a p z) = + MvPolynomial.X (.inr (0 : Fin (n + 1))) ^ p * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ^ a * + MvPolynomial.rename oldIndex + (presentedNormalFormLinearEquiv k n z) := by + letI : Algebra k (IteratedPairStage k n) := iteratedPairStageAlgebra k n + letI : Algebra k (CoordinateStage (B := IteratedPairStage k n)) := + coordinateStageAlgebra + letI : Algebra k (PairStage (B := IteratedPairStage k n)) := pairStageAlgebra + rw [presentedCoefficientOrdered] + rw [presentedNormalFormLinearEquiv, LinearEquiv.trans_apply, + AlgEquiv.toLinearEquiv_apply] + have hmap : presentedIteratedEquiv k (n + 1) + (previousWeylEmbedding k n z * + presentedCoordinate k n ^ a * presentedMomentum k n ^ p) = + presentedIteratedEquiv k (n + 1) (previousWeylEmbedding k n z) * + presentedIteratedEquiv k (n + 1) (presentedCoordinate k n) ^ a * + presentedIteratedEquiv k (n + 1) (presentedMomentum k n) ^ p := by + simp only [map_mul, map_pow] + rw [hmap] + change iteratedNormalFormLinearEquiv k (n + 1) + (presentedToIterated k (n + 1) (previousWeylEmbedding k n z) * + presentedToIterated k (n + 1) (presentedCoordinate k n) ^ a * + presentedToIterated k (n + 1) (presentedMomentum k n) ^ p) = _ + have hprevious := DFunLike.congr_fun (presentedToIterated_previous k n) z + rw [AlgHom.comp_apply, AlgHom.comp_apply] at hprevious + rw [hprevious, presentedToIterated_coordinate, + presentedToIterated_momentum] + change iteratedNormalFormLinearEquiv k (n + 1) + (iteratedCoefficientOrdered k n a p (presentedToIterated k n z)) = _ + rw [iteratedNormalFormLinearEquiv_coefficient_ordered] + rfl + +/-- Exact normal-ordering formula for two newest-pair blocks. Every correction +term lowers both the coordinate and momentum exponents by the same amount. -/ +theorem presentedCoefficientOrdered_mul + (n a b c d : ℕ) (z₁ z₂ : PresentedWeyl k n) : + presentedCoefficientOrdered k n a b z₁ * + presentedCoefficientOrdered k n c d z₂ = + ∑ i ∈ Finset.range (b + 1), + if i ≤ c then + (b.choose i * c.descFactorial i) • + presentedCoefficientOrdered k n (a + c - i) (b + d - i) (z₁ * z₂) + else 0 := by + let X := presentedCoordinate k n + let P := presentedMomentum k n + let Z₁ := previousWeylEmbedding k n z₁ + let Z₂ := previousWeylEmbedding k n z₂ + have hX : Commute X Z₂ := presentedCoordinate_commutes_previous k n z₂ + have hP : Commute P Z₂ := presentedMomentum_commutes_previous k n z₂ + have hblock : Commute (X ^ a * P ^ b) Z₂ := + (hX.pow_left a).mul_left (hP.pow_left b) + have hPX : P * X - X * P = 1 := by + rw [show P * X = X * P + 1 from presentedMomentum_mul_coordinate k n] + noncomm_ring + rw [presentedCoefficientOrdered, presentedCoefficientOrdered] + change (Z₁ * X ^ a * P ^ b) * (Z₂ * X ^ c * P ^ d) = _ + calc + (Z₁ * X ^ a * P ^ b) * (Z₂ * X ^ c * P ^ d) = + Z₁ * ((X ^ a * P ^ b) * Z₂) * (X ^ c * P ^ d) := by + noncomm_ring + _ = (Z₁ * Z₂ * X ^ a) * (P ^ b * X ^ c) * P ^ d := by + rw [hblock.eq] + noncomm_ring + _ = (Z₁ * Z₂ * X ^ a) * + (∑ i ∈ Finset.range (b + 1), + if i ≤ c then + (b.choose i * c.descFactorial i) • + (X ^ (c - i) * P ^ (b - i)) + else 0) * P ^ d := by + rw [OreAmbient.commutator_pow_mul_pow P X hPX b c] + _ = _ := by + rw [Finset.mul_sum, Finset.sum_mul] + apply Finset.sum_congr rfl + intro i hi + have hib : i ≤ b := by + have := Finset.mem_range.mp hi + omega + by_cases hic : i ≤ c + · simp only [if_pos hic, OreAmbient.mul_nsmul_left, + OreAmbient.nsmul_mul_right, mul_nsmul] + congr 1 + congr 1 + change (Z₁ * Z₂ * X ^ a) * (X ^ (c - i) * P ^ (b - i)) * P ^ d = + previousWeylEmbedding k n (z₁ * z₂) * X ^ (a + c - i) * + P ^ (b + d - i) + rw [map_mul] + rw [show a + c - i = a + (c - i) by omega, + show b + d - i = (b - i) + d by omega, + pow_add, pow_add] + noncomm_ring + · simp [hic] + +-- Compile-time API contract: the exact contraction range, coefficient, and +-- exponent loss are part of the public normal-ordering statement. +example (n a b c d : ℕ) (z₁ z₂ : PresentedWeyl k n) : + presentedCoefficientOrdered k n a b z₁ * + presentedCoefficientOrdered k n c d z₂ = + ∑ i ∈ Finset.range (b + 1), + if i ≤ c then + (b.choose i * c.descFactorial i) • + presentedCoefficientOrdered k n (a + c - i) (b + d - i) (z₁ * z₂) + else 0 := + presentedCoefficientOrdered_mul k n a b c d z₁ z₂ + +/-- Ordered monomials built recursively from the named generators in the +quotient presentation. Older coordinate/momentum pairs occur first; within +each pair the coordinate power precedes the momentum power. -/ +def presentedOrderedMonomial : + (n : ℕ) → (Fin n → ℕ) → (Fin n → ℕ) → PresentedWeyl k n + | 0, _, _ => 1 + | n + 1, a, p => + previousWeylEmbedding k n + (presentedOrderedMonomial n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoordinate k n ^ a 0 * presentedMomentum k n ^ p 0 + +/-- The presentation/Ore equivalence preserves the recursively ordered +monomials, not merely the degree-one generators. -/ +theorem presentedIteratedEquiv_orderedMonomial : + ∀ (n : ℕ) (a p : Fin n → ℕ), + presentedIteratedEquiv k n (presentedOrderedMonomial k n a p) = + iteratedOrderedMonomial k n a p := by + intro n + induction n with + | zero => + intro a p + simp [presentedOrderedMonomial, iteratedOrderedMonomial] + | succ n ih => + intro a p + rw [presentedOrderedMonomial, iteratedOrderedMonomial, map_mul, map_mul, + map_pow, map_pow, presentedIteratedEquiv] + change + presentedToIterated k (n + 1) + (previousWeylEmbedding k n + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ))) * + presentedToIterated k (n + 1) (presentedCoordinate k n) ^ a 0 * + presentedToIterated k (n + 1) (presentedMomentum k n) ^ p 0 = _ + have hprevious := DFunLike.congr_fun + (presentedToIterated_previous k n) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) + rw [AlgHom.comp_apply, AlgHom.comp_apply] at hprevious + have hih := ih (fun i => a i.succ) (fun i => p i.succ) + change presentedToIterated k n + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) = _ at hih + rw [hprevious, hih, presentedToIterated_coordinate, + presentedToIterated_momentum] + rfl + +/-- Every ordered product of named presentation generators has the expected +commutative symbol monomial as its checked normal form. -/ +theorem presentedOrderedMonomial_normal (n : ℕ) (a p : Fin n → ℕ) : + presentedNormalFormLinearEquiv k n + (presentedOrderedMonomial k n a p) = + MvPolynomial.monomial (phaseExponent a p) 1 := by + rw [presentedNormalFormLinearEquiv, LinearEquiv.trans_apply, + AlgEquiv.toLinearEquiv_apply, presentedIteratedEquiv_orderedMonomial, + iteratedOrderedMonomial_normal] + +/-- A free-module basis on the presented Weyl algebra, pulled back from the +standard monomial basis of the symbol polynomial space. -/ +def presentedNormalFormBasis (n : Nat) : + Module.Basis (PhaseVar n →₀ ℕ) k (PresentedWeyl k n) := + (MvPolynomial.basisMonomials (PhaseVar n) k).map + (presentedNormalFormLinearEquiv k n).symm + +@[simp] theorem presentedNormalFormBasis_apply (n : Nat) + (m : PhaseVar n →₀ ℕ) : + presentedNormalFormBasis k n m = + (presentedNormalFormLinearEquiv k n).symm (MvPolynomial.monomial m 1) := by + rfl + +/-- Split a finite phase exponent into its coordinate and momentum parts. -/ +theorem phaseExponent_split {n : ℕ} (m : PhaseVar n →₀ ℕ) : + phaseExponent (fun i => m (.inl i)) (fun i => m (.inr i)) = m := by + ext i + cases i <;> rfl + +/-- The transported normal-form basis consists exactly of the recursively +ordered products of the named Weyl generators. -/ +theorem presentedNormalFormBasis_eq_orderedMonomial (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + presentedNormalFormBasis k n m = + presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i)) := by + apply (presentedNormalFormLinearEquiv k n).injective + rw [presentedNormalFormBasis_apply, LinearEquiv.apply_symm_apply, + presentedOrderedMonomial_normal, phaseExponent_split] + +/-- The PBW basis of the presented Weyl algebra, indexed by coordinate and +momentum exponent vectors. -/ +def presentedPBWBasis (n : Nat) : + Module.Basis (PhaseVar n →₀ ℕ) k (PresentedWeyl k n) := + presentedNormalFormBasis k n + +@[simp] theorem presentedPBWBasis_apply (n : ℕ) + (m : PhaseVar n →₀ ℕ) : + presentedPBWBasis k n m = + presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i)) := by + exact presentedNormalFormBasis_eq_orderedMonomial k n m + + +end + +end Stafford38.WeylPBW diff --git a/LeanPool/Stafford38/Stafford38/Weyl/PBWFirstContraction.lean b/LeanPool/Stafford38/Stafford38/Weyl/PBWFirstContraction.lean new file mode 100644 index 0000000000..1bf38f42cf --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/PBWFirstContraction.lean @@ -0,0 +1,442 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.FilteredCommutator + +/-! +# The first PBW contraction + +This file extracts the degree-one contraction term from the recursive ordered +PBW multiplication formula. It is kept separate from the downstream +commutator argument so that the one-sided normal-ordering calculation is an +independent input. +-/ + +namespace Stafford38.WeylPBWFirstContraction + +open Stafford38.Characteristic +open Stafford38.WeylFilteredCommutator +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +private theorem weightedHomogeneousComponent_monomial_mul_eq_zero_of_lt + {n T : ℕ} (w : PhaseVar n → ℕ) (s : PhaseVar n →₀ ℕ) + (f : SymbolRing k n) (hT : T < monomialWeight w s) : + MvPolynomial.weightedHomogeneousComponent w T + (MvPolynomial.monomial s 1 * f) = 0 := by + classical + ext q + rw [MvPolynomial.coeff_weightedHomogeneousComponent, + MvPolynomial.coeff_monomial_mul', MvPolynomial.coeff_zero] + by_cases hsq : s ≤ q + · rw [if_pos hsq, one_mul] + have hsplit : s + (q - s) = q := by + rw [add_comm] + exact tsub_add_cancel_of_le hsq + have hweight : + monomialWeight w q = + monomialWeight w s + monomialWeight w (q - s) := by + rw [← hsplit] + simp [monomialWeight, Finsupp.sum_add_index, add_mul] + have hne : monomialWeight w q ≠ T := by omega + rw [finsupp_weight_eq_monomialWeight, if_neg hne] + · rw [if_neg hsq] + simp + +private theorem phaseExponent_old_contraction_exponents + (n : ℕ) (a p c q : Fin (n + 1) → ℕ) (i : Fin n) : + (phaseExponent a p - + Finsupp.single (.inr i.succ : PhaseVar (n + 1)) 1) + + (phaseExponent c q - + Finsupp.single (.inl i.succ : PhaseVar (n + 1)) 1) = + extendPhaseExponent n (a 0 + c 0) (p 0 + q 0) 0 + + (((phaseExponent (fun j => a j.succ) (fun j => p j.succ) - + Finsupp.single (.inr i : PhaseVar n) 1) + + (phaseExponent (fun j => c j.succ) (fun j => q j.succ) - + Finsupp.single (.inl i : PhaseVar n) 1)).mapDomain oldIndex) := by + classical + have hmapCoordinate (s : PhaseVar n →₀ ℕ) (j : Fin n) : + Finsupp.mapDomain oldIndex s (.inl j.succ) = s (.inl j) := by + change Finsupp.mapDomain oldIndex s (oldIndex (.inl j)) = _ + rw [Finsupp.mapDomain_apply oldIndex_injective] + have hmapMomentum (s : PhaseVar n →₀ ℕ) (j : Fin n) : + Finsupp.mapDomain oldIndex s (.inr j.succ) = s (.inr j) := by + change Finsupp.mapDomain oldIndex s (oldIndex (.inr j)) = _ + rw [Finsupp.mapDomain_apply oldIndex_injective] + have hmapCoordinateZero (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inl (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨v, hv⟩ + cases v <;> simp [oldIndex, Fin.succ_ne_zero] at hv + have hmapMomentumZero (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inr (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨v, hv⟩ + cases v <;> simp [oldIndex, Fin.succ_ne_zero] at hv + ext v + rcases v with v | v + · refine Fin.cases ?_ (fun j => ?_) v + · simp [phaseExponent, extendPhaseExponent, oldIndex, + Finsupp.single_apply, Fin.succ_ne_zero, hmapCoordinateZero] + · have hzero : (0 : Fin (n + 1)) ≠ j.succ := + Ne.symm (Fin.succ_ne_zero j) + simp [phaseExponent, extendPhaseExponent, oldIndex, + Finsupp.single_apply, Fin.succ_ne_zero, hzero, hmapCoordinate] + · refine Fin.cases ?_ (fun j => ?_) v + · simp [phaseExponent, extendPhaseExponent, oldIndex, + Finsupp.single_apply, Fin.succ_ne_zero, hmapMomentumZero] + · have hzero : (0 : Fin (n + 1)) ≠ j.succ := + Ne.symm (Fin.succ_ne_zero j) + simp [phaseExponent, extendPhaseExponent, oldIndex, + Finsupp.single_apply, Fin.succ_ne_zero, hzero, hmapMomentum] + +private theorem firstContraction_old_term + (n : ℕ) (a p c q : Fin (n + 1) → ℕ) (i : Fin n) : + MvPolynomial.pderiv (.inr i.succ) + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) * + MvPolynomial.pderiv (.inl i.succ) + (MvPolynomial.monomial (phaseExponent c q) 1) = + MvPolynomial.monomial + (extendPhaseExponent n (a 0 + c 0) (p 0 + q 0) 0) 1 * + MvPolynomial.rename oldIndex + (MvPolynomial.pderiv (.inr i) + (MvPolynomial.monomial + (phaseExponent (fun j => a j.succ) (fun j => p j.succ)) 1) * + MvPolynomial.pderiv (.inl i) + (MvPolynomial.monomial + (phaseExponent (fun j => c j.succ) (fun j => q j.succ)) 1)) := by + classical + simp only [MvPolynomial.pderiv_monomial, + MvPolynomial.monomial_mul, MvPolynomial.rename_monomial, map_mul] + rw [phaseExponent_old_contraction_exponents n a p c q i] + simp [phaseExponent] + +private theorem phaseExponent_newest_contraction_exponents + (n : ℕ) (a p c q : Fin (n + 1) → ℕ) + (hp : 0 < p 0) (hc : 0 < c 0) : + (phaseExponent a p - + Finsupp.single (.inr (0 : Fin (n + 1))) 1) + + (phaseExponent c q - + Finsupp.single (.inl (0 : Fin (n + 1))) 1) = + extendPhaseExponent n (a 0 + c 0 - 1) (p 0 + q 0 - 1) 0 + + (phaseExponent (fun j => a j.succ) (fun j => p j.succ) + + phaseExponent (fun j => c j.succ) (fun j => q j.succ)).mapDomain + oldIndex := by + classical + rw [phaseExponent_succ_eq_extend, phaseExponent_succ_eq_extend] + ext v + rcases v with v | v + · refine Fin.cases ?_ (fun j => ?_) v + · have hmap (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inl (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨w, hw⟩ + cases w <;> simp [oldIndex, Fin.succ_ne_zero] at hw + simp [extendPhaseExponent, Finsupp.single_apply, hmap] + omega + · have hmap (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inl j.succ) = s (.inl j) := by + change Finsupp.mapDomain oldIndex s (oldIndex (.inl j)) = _ + rw [Finsupp.mapDomain_apply oldIndex_injective] + have hzero : (0 : Fin (n + 1)) ≠ j.succ := + Ne.symm (Fin.succ_ne_zero j) + simp [extendPhaseExponent, phaseExponent, Finsupp.single_apply, + hmap, hzero, Fin.succ_ne_zero] + · refine Fin.cases ?_ (fun j => ?_) v + · have hmap (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inr (0 : Fin (n + 1))) = 0 := by + apply Finsupp.mapDomain_notin_range + rintro ⟨w, hw⟩ + cases w <;> simp [oldIndex, Fin.succ_ne_zero] at hw + simp [extendPhaseExponent, Finsupp.single_apply, hmap] + omega + · have hmap (s : PhaseVar n →₀ ℕ) : + Finsupp.mapDomain oldIndex s (.inr j.succ) = s (.inr j) := by + change Finsupp.mapDomain oldIndex s (oldIndex (.inr j)) = _ + rw [Finsupp.mapDomain_apply oldIndex_injective] + have hzero : (0 : Fin (n + 1)) ≠ j.succ := + Ne.symm (Fin.succ_ne_zero j) + simp [extendPhaseExponent, phaseExponent, Finsupp.single_apply, + hmap, hzero, Fin.succ_ne_zero] + +private theorem firstContraction_newest_term + (n : ℕ) (a p c q : Fin (n + 1) → ℕ) + (hp : 0 < p 0) (hc : 0 < c 0) : + ((p 0).choose 1 * (c 0).descFactorial 1) • + (MvPolynomial.monomial + (extendPhaseExponent n (a 0 + c 0 - 1) + (p 0 + q 0 - 1) 0) (1 : k) * + MvPolynomial.rename oldIndex + (MvPolynomial.monomial + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) 1 * + MvPolynomial.monomial + (phaseExponent (fun i => c i.succ) (fun i => q i.succ)) 1)) = + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent a p) 1) * + MvPolynomial.pderiv (.inl (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent c q) 1) := by + classical + simp only [MvPolynomial.pderiv_monomial, + MvPolynomial.monomial_mul, MvPolynomial.rename_monomial, map_mul] + rw [phaseExponent_newest_contraction_exponents n a p c q hp hc] + simp [phaseExponent, Nat.choose, Nat.descFactorial] + rw [← map_natCast + (MvPolynomial.C : k →+* SymbolRing k (n + 1)) (p 0), + ← map_natCast + (MvPolynomial.C : k →+* SymbolRing k (n + 1)) (c 0), + ← map_mul, MvPolynomial.C_mul_monomial, mul_one] + +/-- Splitting off the newest pair decomposes the first contraction into its +newest-pair term and the renamed first contraction in the older pairs. -/ +theorem pbwFirstContraction_phaseExponent_succ + (n : ℕ) (a p c q : Fin (n + 1) → ℕ) : + pbwFirstContraction k (phaseExponent a p) (phaseExponent c q) = + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent a p) 1) * + MvPolynomial.pderiv (.inl (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent c q) 1) + + MvPolynomial.monomial + (extendPhaseExponent n (a 0 + c 0) (p 0 + q 0) 0) 1 * + MvPolynomial.rename oldIndex + (pbwFirstContraction k + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) + (phaseExponent (fun i => c i.succ) (fun i => q i.succ))) := by + rw [pbwFirstContraction, Fin.sum_univ_succ, + pbwFirstContraction, map_sum, Finset.mul_sum] + congr 1 + apply Finset.sum_congr rfl + intro i hi + exact firstContraction_old_term k n a p c q i + +/-- For ordered monomials of positive total differential order, the component +one below the top order of their product is exactly the one-contraction term. -/ +theorem presentedOrderedMonomial_mul_firstContraction : + ∀ (n : ℕ) (a p c q : Fin n → ℕ), + 0 < monomialWeight (@orderWeight n) (phaseExponent a p) + + monomialWeight (@orderWeight n) (phaseExponent c q) → + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) (phaseExponent a p) + + monomialWeight (@orderWeight n) (phaseExponent c q) - 1) + (presentedOrderedMonomial k n a p * + presentedOrderedMonomial k n c q) = + pbwFirstContraction k (phaseExponent a p) (phaseExponent c q) := by + intro n + induction n with + | zero => + intro a p c q hpos + have hap : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + have hcq : phaseExponent c q = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [hap, hcq] at hpos + simp [monomialWeight] at hpos + | succ n ih => + intro a p c q hpos + let mold := + phaseExponent (fun i => a i.succ) (fun i => p i.succ) + let qold := + phaseExponent (fun i => c i.succ) (fun i => q i.succ) + let z := + presentedOrderedMonomial k n (fun i => a i.succ) (fun i => p i.succ) * + presentedOrderedMonomial k n (fun i => c i.succ) (fun i => q i.succ) + let L := monomialWeight (@orderWeight n) mold + + monomialWeight (@orderWeight n) qold + let t := p 0 + q 0 + have htarget : + monomialWeight (@orderWeight (n + 1)) (phaseExponent a p) + + monomialWeight (@orderWeight (n + 1)) (phaseExponent c q) = + L + t := by + rw [monomialWeight_phaseExponent_succ_order, + monomialWeight_phaseExponent_succ_order] + dsimp [L, t, mold, qold] + omega + have htotal : 0 < L + t := by + rwa [htarget] at hpos + have hzOrder : z ∈ orderPiece k n L := by + dsimp [z, L, mold, qold] + exact presentedOrderedMonomial_mul_mem_orderPiece k n + (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ) + have hzeroTerm : + presentedPrincipalComponent k (@orderWeight (n + 1)) (L + t - 1) + (presentedCoefficientOrdered k n (a 0 + c 0) t z) = + MvPolynomial.monomial + (extendPhaseExponent n (a 0 + c 0) t 0) 1 * + MvPolynomial.rename oldIndex + (pbwFirstContraction k mold qold) := by + by_cases hL : L = 0 + · have ht : 0 < t := by omega + have hvanish : + presentedPrincipalComponent k (@orderWeight (n + 1)) + (L + t - 1) + (presentedCoefficientOrdered k n (a 0 + c 0) t z) = 0 := by + rw [presentedPrincipalComponent, LinearMap.comp_apply] + change MvPolynomial.weightedHomogeneousComponent + (@orderWeight (n + 1)) (L + t - 1) + (presentedNormalFormLinearEquiv k (n + 1) + (presentedCoefficientOrdered k n (a 0 + c 0) t z)) = 0 + rw [presentedNormalFormLinearEquiv_previous_ordered_monomial] + apply weightedHomogeneousComponent_monomial_mul_eq_zero_of_lt k + rw [monomialWeight_extend_zero_order] + omega + have hmold : monomialWeight (@orderWeight n) mold = 0 := by + dsimp [L] at hL + omega + rw [hvanish, + pbwFirstContraction_eq_zero_of_orderWeight_eq_zero + k mold qold hmold, map_zero, mul_zero] + · have hLpos : 0 < L := Nat.pos_of_ne_zero hL + have hih := ih + (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ) hLpos + change presentedPrincipalComponent k (@orderWeight n) (L - 1) z = + pbwFirstContraction k mold qold at hih + rw [show L + t - 1 = (L - 1) + t by omega, + presentedPrincipalComponent_coefficientOrdered_order, hih] + rw [htarget] + change presentedPrincipalComponent k (@orderWeight (n + 1)) (L + t - 1) + (presentedCoefficientOrdered k n (a 0) (p 0) + (presentedOrderedMonomial k n + (fun i => a i.succ) (fun i => p i.succ)) * + presentedCoefficientOrdered k n (c 0) (q 0) + (presentedOrderedMonomial k n + (fun i => c i.succ) (fun i => q i.succ))) = _ + rw [presentedCoefficientOrdered_mul] + simp only [map_sum] + have hmem0 : 0 ∈ Finset.range (p 0 + 1) := by simp + rw [Finset.sum_eq_add_sum_sdiff_singleton_of_mem hmem0] + simp only [Nat.zero_le, if_true, Nat.choose_zero_right, + Nat.descFactorial_zero, mul_one, one_nsmul, Nat.sub_zero] + change presentedPrincipalComponent k (@orderWeight (n + 1)) (L + t - 1) + (presentedCoefficientOrdered k n (a 0 + c 0) t z) + _ = _ + rw [hzeroTerm] + rw [pbwFirstContraction_phaseExponent_succ] + by_cases hp0 : p 0 = 0 + · have hempty : Finset.range (p 0 + 1) \ {0} = ∅ := by + ext i + simp [hp0] + rw [hempty] + simp [MvPolynomial.pderiv_monomial, phaseExponent, hp0, + t, mold, qold] + · have hp : 0 < p 0 := Nat.pos_of_ne_zero hp0 + by_cases hc0 : c 0 = 0 + · have hrest : + ∑ i ∈ Finset.range (p 0 + 1) \ {0}, + presentedPrincipalComponent k (@orderWeight (n + 1)) + (L + t - 1) + (if i ≤ c 0 then + ((p 0).choose i * (c 0).descFactorial i) • + presentedCoefficientOrdered k n + (a 0 + c 0 - i) (p 0 + q 0 - i) z + else 0) = 0 := by + apply Finset.sum_eq_zero + intro i hi + have hi' := Finset.mem_sdiff.mp hi + have hi0 : i ≠ 0 := by simpa using hi'.2 + have hnot : ¬ i ≤ c 0 := by omega + simp [hnot] + rw [hrest] + simp [MvPolynomial.pderiv_monomial, phaseExponent, hc0, + t, mold, qold] + · have hc : 0 < c 0 := Nat.pos_of_ne_zero hc0 + have honeMem : 1 ∈ Finset.range (p 0 + 1) \ {0} := by + simp [hp] + have hone : + presentedPrincipalComponent k (@orderWeight (n + 1)) + (L + t - 1) + (((p 0).choose 1 * (c 0).descFactorial 1) • + presentedCoefficientOrdered k n + (a 0 + c 0 - 1) (p 0 + q 0 - 1) z) = + MvPolynomial.pderiv (.inr (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent a p) 1) * + MvPolynomial.pderiv (.inl (0 : Fin (n + 1))) + (MvPolynomial.monomial (phaseExponent c q) 1) := by + simp only [map_nsmul] + rw [show L + t - 1 = L + (p 0 + q 0 - 1) by omega, + presentedPrincipalComponent_coefficientOrdered_order] + have htop := presentedOrderedMonomial_mul_principal_order k n + (fun i => a i.succ) (fun i => p i.succ) + (fun i => c i.succ) (fun i => q i.succ) + change presentedPrincipalComponent k (@orderWeight n) L z = + MvPolynomial.monomial mold 1 * + MvPolynomial.monomial qold 1 at htop + rw [htop] + exact firstContraction_newest_term k n a p c q hp hc + rw [Finset.sum_eq_single 1] + · simp only [show 1 ≤ c 0 from hc, if_true] + rw [hone] + abel + · intro i hi hi1 + have hi' := Finset.mem_sdiff.mp hi + have hirange : i ∈ Finset.range (p 0 + 1) := hi'.1 + have hi0 : i ≠ 0 := by simpa using hi'.2 + have hip : i ≤ p 0 := by + have := Finset.mem_range.mp hirange + omega + by_cases hic : i ≤ c 0 + · simp only [if_pos hic, map_nsmul] + have hterm := presentedCoefficientOrdered_mem_orderPiece k n L + (a 0 + c 0 - i) (p 0 + q 0 - i) z hzOrder + have hlt : L + (p 0 + q 0 - i) < L + t - 1 := by + dsimp [t] + omega + have hvanish := + presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@orderWeight (n + 1)) _ hterm hlt + rw [hvanish, nsmul_zero] + · simp [hic] + · exact fun h => (h honeMem).elim + +/-- The exact first-contraction coefficient for arbitrary PBW basis vectors. +The positivity hypothesis says that the two monomials have positive combined +differential order, so the component one below the top is unambiguous. -/ +theorem presentedPBWBasis_mul_firstContraction {n : ℕ} + (m q : PhaseVar n →₀ ℕ) + (hpos : 0 < monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q) : + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) m + + monomialWeight (@orderWeight n) q - 1) + (presentedPBWBasis k n m * presentedPBWBasis k n q) = + pbwFirstContraction k m q := by + have hpos' : + 0 < monomialWeight (@orderWeight n) + (phaseExponent (fun i => m (.inl i)) (fun i => m (.inr i))) + + monomialWeight (@orderWeight n) + (phaseExponent (fun i => q (.inl i)) (fun i => q (.inr i))) := by + simpa only [phaseExponent_split] using hpos + rw [presentedPBWBasis_apply, presentedPBWBasis_apply, + ← phaseExponent_split m, ← phaseExponent_split q] + exact presentedOrderedMonomial_mul_firstContraction k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + (fun i => q (.inl i)) (fun i => q (.inr i)) hpos' + +/-- The unconditional two-element subprincipal commutator formula. -/ +theorem principalComponent_commutator_eq_neg_poisson + {n r s : ℕ} {a b : PresentedWeyl k n} + (ha : a ∈ orderPiece k n r) (hb : b ∈ orderPiece k n s) : + presentedPrincipalComponent k (@orderWeight n) (r + s - 1) + (Stafford.commutator a b) = + -poissonBracket + (presentedPrincipalComponent k (@orderWeight n) r a) + (presentedPrincipalComponent k (@orderWeight n) s b) := + principalComponent_commutator_eq_neg_poisson_of_firstContraction k + (presentedPBWBasis_mul_firstContraction k) ha hb + + +end + +end Stafford38.WeylPBWFirstContraction diff --git a/LeanPool/Stafford38/Stafford38/Weyl/PBWMonicBridge.lean b/LeanPool/Stafford38/Stafford38/Weyl/PBWMonicBridge.lean new file mode 100644 index 0000000000..3068866632 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/PBWMonicBridge.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.MonicNormalization + +/-! +# From principal-axis normalization to PBW monicity + +Axis restriction does not merge coefficients: its degree-`N` coefficient is +exactly the coefficient of the pure selected-variable monomial. The same pure +coefficient passes unchanged from the degree-`N` principal component to the +full checked PBW normal form. Together with the Bernstein bound, this yields a +coefficient-one pure momentum term and excludes every higher momentum power. + +The resulting data retain the symplectic matrices, inverse identities, scalar, +and exact normalized image. Converting this PBW statement to `Polynomial.Monic` +for the outer Ore layer remains separate. +-/ + +namespace Stafford38.WeylPBWMonicBridge + +open Stafford38.Characteristic +open Stafford38.CharacteristicHomogeneousChart +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylMonicNormalization +open Stafford38.WeylPBW +open Stafford38.WeylSymplectic + +noncomputable section +universe u +variable (k : Type u) [Field k] + +theorem coeff_axisPolynomial {n : ℕ} (t : PhaseVar n) + (P : SymbolRing k n) (N : ℕ) : + MvPolynomial.coeff (Finsupp.single () N) (axisPolynomial k t P) = + MvPolynomial.coeff (Finsupp.single t N) P := by + induction P using MvPolynomial.induction_on' with + | monomial m c => + by_cases hsub : ∀ i ∈ m.support, i = t + · have hm : m = Finsupp.single t (m t) := by + ext i + by_cases hit : i = t + · subst i + simp + · have hi : i ∉ m.support := by + intro him + exact hit (hsub i him) + rw [Finsupp.notMem_support_iff.mp hi] + rw [Finsupp.single_apply] + simp [Ne.symm hit] + rw [hm] + rw [axisPolynomial, MvPolynomial.aeval_monomial] + rw [Finsupp.prod_single_index (by simp)] + simp [MvPolynomial.X_pow_eq_monomial] + by_cases hmt : m t = N + · simp [hmt] + · have hs : Finsupp.single t (m t) ≠ Finsupp.single t N := by + intro h + exact hmt (Finsupp.single_injective t h) + simp [hmt, hs] + · push_neg at hsub + rcases hsub with ⟨i, hi, hit⟩ + have hmne : m ≠ Finsupp.single t N := by + intro hm + subst m + simp [Finsupp.single_apply, Ne.symm hit] at hi + rw [axisPolynomial, MvPolynomial.aeval_monomial] + have hz : m.prod + (fun i e => (if i = t then MvPolynomial.X () + else (0 : MvPolynomial Unit k)) ^ e) = 0 := by + rw [Finsupp.prod] + apply Finset.prod_eq_zero hi + have hmi : m i ≠ 0 := Finsupp.mem_support_iff.mp hi + simp [hit, hmi] + rw [hz, mul_zero] + simp [MvPolynomial.coeff_monomial, hmne] + | add p q hp hq => + simp [map_add, hp, hq] + +theorem coeff_principal_pure_eq_normalForm {n N : ℕ} + (t : PhaseVar n) (d : PresentedWeyl k n) : + MvPolynomial.coeff (Finsupp.single t N) + (presentedPrincipalComponent k (@bernsteinWeight n) N d) = + MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n d) := by + rw [coeff_presentedPrincipalComponent] + simp [monomialWeight, bernsteinWeight] + +def IsPBWMonicAt {n : ℕ} (t : PhaseVar n) (N : ℕ) + (d : PresentedWeyl k n) : Prop := + d ∈ bernsteinPiece k n N ∧ + MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n d) = 1 + +theorem coeff_normalForm_eq_zero_of_exponent_gt {n N : ℕ} + {t : PhaseVar n} {d : PresentedWeyl k n} + (hd : d ∈ bernsteinPiece k n N) {m : PhaseVar n →₀ ℕ} + (hmt : N < m t) : + MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n d) = 0 := by + by_contra hcoeff + have hweight := (mem_presentedWeightPiece k (@bernsteinWeight n) N d).mp + hd m hcoeff + have hle : m t ≤ monomialWeight (@bernsteinWeight n) m := by + simpa [monomialWeight, bernsteinWeight] using + Finsupp.single_eval_le_sum m (g := id) rfl (fun _ => Nat.zero_le _) t + omega + +structure NormalizedPBWChartData {n : ℕ} (t : PhaseVar n) (N : ℕ) + (d : PresentedWeyl k n) where + M : Matrix (PhaseVar n) (PhaseVar n) k + Ninv : Matrix (PhaseVar n) (PhaseVar n) k + c : k + hM : M * standardForm k n * Matrix.transpose M = standardForm k n + hNinv : Ninv * standardForm k n * Matrix.transpose Ninv = standardForm k n + hMN : M * Ninv = 1 + hNM : Ninv * M = 1 + hc : c ≠ 0 + mem_piece : normalizedSymplecticImage k M hM c d ∈ bernsteinPiece k n N + pure_coeff : MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n + (normalizedSymplecticImage k M hM c d)) = 1 + +theorem HasNormalizedSymplecticChart.toNormalizedPBWChartData + {n N : ℕ} {t : PhaseVar n} {d : PresentedWeyl k n} + (hchart : HasNormalizedSymplecticChart k t N d) : + Nonempty (NormalizedPBWChartData k t N d) := by + rcases hchart with ⟨M, Ninv, c, hM, hNinv, hMN, hNM, hc, hpiece, haxis⟩ + refine ⟨⟨M, Ninv, c, hM, hNinv, hMN, hNM, hc, hpiece, ?_⟩⟩ + rw [← coeff_principal_pure_eq_normalForm k] + rw [← coeff_axisPolynomial k] + exact haxis + +theorem HasNormalizedSymplecticChart.purePBWCoefficient + {n N : ℕ} {t : PhaseVar n} {d : PresentedWeyl k n} + (hchart : HasNormalizedSymplecticChart k t N d) : + ∃ d' : PresentedWeyl k n, IsPBWMonicAt k t N d' := by + rcases hchart with ⟨M, Ninv, c, hM, hNinv, hMN, hNM, hc, hpiece, haxis⟩ + refine ⟨normalizedSymplecticImage k M hM c d, hpiece, ?_⟩ + rw [← coeff_principal_pure_eq_normalForm k] + rw [← coeff_axisPolynomial k] + exact haxis + +/- Exact statement pins for the coefficient bridge and retained chart data. -/ +theorem coeff_axisPolynomial_statement {n : ℕ} (t : PhaseVar n) + (P : SymbolRing k n) (N : ℕ) : + MvPolynomial.coeff (Finsupp.single () N) (axisPolynomial k t P) = + MvPolynomial.coeff (Finsupp.single t N) P := + coeff_axisPolynomial k t P N + +theorem isPBWMonicAt_statement {n : ℕ} (t : PhaseVar n) (N : ℕ) + (d : PresentedWeyl k n) : + IsPBWMonicAt k t N d ↔ + d ∈ bernsteinPiece k n N ∧ + MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n d) = 1 := + Iff.rfl + +theorem coeff_principal_pure_eq_normalForm_statement {n N : ℕ} + (t : PhaseVar n) (d : PresentedWeyl k n) : + MvPolynomial.coeff (Finsupp.single t N) + (presentedPrincipalComponent k (@bernsteinWeight n) N d) = + MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n d) := + coeff_principal_pure_eq_normalForm k t d + +theorem coeff_normalForm_eq_zero_of_exponent_gt_statement {n N : ℕ} + {t : PhaseVar n} {d : PresentedWeyl k n} + (hd : d ∈ bernsteinPiece k n N) {m : PhaseVar n →₀ ℕ} + (hmt : N < m t) : + MvPolynomial.coeff m (presentedNormalFormLinearEquiv k n d) = 0 := + coeff_normalForm_eq_zero_of_exponent_gt k hd hmt + +theorem normalizedPBWChartData_fields {n N : ℕ} {t : PhaseVar n} + {d : PresentedWeyl k n} (D : NormalizedPBWChartData k t N d) : + D.M * standardForm k n * Matrix.transpose D.M = standardForm k n ∧ + D.Ninv * standardForm k n * Matrix.transpose D.Ninv = standardForm k n ∧ + D.M * D.Ninv = 1 ∧ D.Ninv * D.M = 1 ∧ D.c ≠ 0 ∧ + normalizedSymplecticImage k D.M D.hM D.c d ∈ bernsteinPiece k n N ∧ + MvPolynomial.coeff (Finsupp.single t N) + (presentedNormalFormLinearEquiv k n + (normalizedSymplecticImage k D.M D.hM D.c d)) = 1 := + ⟨D.hM, D.hNinv, D.hMN, D.hNM, D.hc, D.mem_piece, D.pure_coeff⟩ + +theorem normalizedPBWChartData_statement + {n N : ℕ} {t : PhaseVar n} {d : PresentedWeyl k n} + (hchart : HasNormalizedSymplecticChart k t N d) : + Nonempty (NormalizedPBWChartData k t N d) := + HasNormalizedSymplecticChart.toNormalizedPBWChartData k hchart + + +end +end Stafford38.WeylPBWMonicBridge diff --git a/LeanPool/Stafford38/Stafford38/Weyl/PresentedScalarExtension.lean b/LeanPool/Stafford38/Stafford38/Weyl/PresentedScalarExtension.lean new file mode 100644 index 0000000000..f50d28a041 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/PresentedScalarExtension.lean @@ -0,0 +1,611 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence +import LeanPool.Stafford38.Stafford38.Weyl.Universal +import LeanPool.Stafford38.Stafford38.Weyl.PBW +import LeanPool.Stafford38.Stafford38.Weyl.Filtration +import LeanPool.Stafford38.Stafford38.Weyl.LeadingSymbol +import LeanPool.Stafford38.Stafford38.Weyl.PBWMonicBridge +import LeanPool.Stafford38.Stafford38.Weyl.EulerResidue +import LeanPool.Stafford38.Stafford38.Characteristic.InitialIdeal +import LeanPool.Stafford38.Stafford38.Characteristic.GeometricSupportDescent +import LeanPool.Stafford38.Stafford38.UniversalAssembly +import LeanPool.Stafford38.Stafford38.CanonicalSupportVanishingReduction + +/-! +# Coefficient extension for the presented Weyl algebra + +This file records the concrete map needed before any characteristic-support +descent can be attempted. The source is the quotient presentation over `k` +and the target is the same presentation over an extension field `K`. The map +is defined by the quotient universal property; in particular, no PBW +identification or base-change theorem is used in its definition. + +The file also proves injectivity, PBW normal-form and filtration transport, +PBW monicity, canonical-right-ideal transport in the usable direction, and the +resulting source-to-target order-initial-ideal inclusion. The reverse filtered +comparison is recorded as an explicit contract below and proved in +`FilteredScalarLifting.lean`; no base-change equality is treated as +definitional. +-/ + +namespace Stafford38.Weyl.PresentedScalarExtension + +open Stafford +open AlgebraicAnalysis +open Stafford38.Characteristic +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylFiltration +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylUniversal +open Stafford38.WeylEulerResidue +open Stafford38.CharacteristicInitialIdeal +open Stafford38.Characteristic.GeometricSupportDescent +open Stafford38.Geometry.ScalarExtensionPoints +open Stafford38.EulerSurjectivity + +noncomputable section + +universe u v + +variable {k : Type u} {K : Type v} +variable [Field k] [Field K] [Algebra k K] + +private theorem algebraMap_matrixJ (n : Nat) (i j : Fin n ⊕ Fin n) : + algebraMap k K (Matrix.J (Fin n) k i j) = Matrix.J (Fin n) K i j := by + cases i with + | inl i => + cases j with + | inl j => by_cases h : i = j <;> simp [Matrix.J, h] + | inr j => simp [Matrix.J, Matrix.one_apply] + | inr i => + cases j with + | inl j => simp [Matrix.J, Matrix.one_apply] + | inr j => by_cases h : i = j <;> simp [Matrix.J, h] + +private theorem presentedWeylScalarExtension_commutator (n : Nat) + (i j : Fin n ⊕ Fin n) : + commutator + (freeWeylGenerator (Matrix.J (Fin n) K) i) + (freeWeylGenerator (Matrix.J (Fin n) K) j) = + algebraMap k (PresentedWeyl K n) (Matrix.J (Fin n) k i j) := by + rw [freeWeylGenerator_commutator] + rw [IsScalarTower.algebraMap_apply k K (PresentedWeyl K n)] + rw [algebraMap_matrixJ] + +/-- The coefficient-extension homomorphism on the quotient presentation. -/ +def presentedWeylScalarExtension (n : Nat) : + PresentedWeyl k n →ₐ[k] PresentedWeyl K n := + freeWeylLift (Matrix.J (Fin n) k) + (fun i => freeWeylGenerator (Matrix.J (Fin n) K) i) + (presentedWeylScalarExtension_commutator n) + +@[simp] theorem presentedWeylScalarExtension_generator (n : Nat) + (i : Fin n ⊕ Fin n) : + presentedWeylScalarExtension (k := k) (K := K) n + (freeWeylGenerator (Matrix.J (Fin n) k) i) = + freeWeylGenerator (Matrix.J (Fin n) K) i := by + exact freeWeylLift_generator (Matrix.J (Fin n) k) + (fun i => freeWeylGenerator (Matrix.J (Fin n) K) i) + (presentedWeylScalarExtension_commutator n) i + +@[simp] theorem presentedWeylScalarExtension_scalar (n : Nat) (a : k) : + presentedWeylScalarExtension (k := k) (K := K) n + (algebraMap k (PresentedWeyl k n) a) = + algebraMap k (PresentedWeyl K n) a := by + exact (presentedWeylScalarExtension (k := k) (K := K) n).commutes a + +theorem presentedWeylScalarExtension_map_mul (n : Nat) + (a b : PresentedWeyl k n) : + presentedWeylScalarExtension (k := k) (K := K) n (a * b) = + presentedWeylScalarExtension (k := k) (K := K) n a * + presentedWeylScalarExtension (k := k) (K := K) n b := by + exact map_mul _ _ _ + +theorem presentedWeylScalarExtension_map_add (n : Nat) + (a b : PresentedWeyl k n) : + presentedWeylScalarExtension (k := k) (K := K) n (a + b) = + presentedWeylScalarExtension (k := k) (K := K) n a + + presentedWeylScalarExtension (k := k) (K := K) n b := by + exact map_add _ _ _ + +theorem presentedWeylScalarExtension_commutes (n : Nat) (a : k) : + presentedWeylScalarExtension (k := k) (K := K) n + (algebraMap k (PresentedWeyl k n) a) = + algebraMap k (PresentedWeyl K n) a := by + exact (presentedWeylScalarExtension (k := k) (K := K) n).commutes a + +/-! ## Compatibility with the recursive presentation -/ + +theorem presentedWeylScalarExtension_previous (n : Nat) + (z : PresentedWeyl k n) : + presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (previousWeylEmbedding k n z) = + previousWeylEmbedding K n + (presentedWeylScalarExtension (k := k) (K := K) n z) := by + let f : PresentedWeyl k n →ₐ[k] PresentedWeyl K (n + 1) := + (presentedWeylScalarExtension (k := k) (K := K) (n + 1)).comp + (previousWeylEmbedding k n) + let g : PresentedWeyl k n →ₐ[k] PresentedWeyl K (n + 1) := + (previousWeylEmbedding K n).restrictScalars k |>.comp + (presentedWeylScalarExtension (k := k) (K := K) n) + have hfg : f = g := by + apply freeWeyl_algHom_ext (k := k) (Matrix.J (Fin n) k) f g + intro i + simp [f, g, oldGenerator] + exact DFunLike.congr_fun hfg z + +theorem presentedWeylScalarExtension_orderedMonomial : + ∀ (n : Nat) (a p : Fin n → ℕ), + presentedWeylScalarExtension (k := k) (K := K) n + (presentedOrderedMonomial k n a p) = + presentedOrderedMonomial K n a p := by + intro n + induction n with + | zero => + intro a p + simp [presentedOrderedMonomial, presentedWeylScalarExtension] + | succ n ih => + intro a p + rw [presentedOrderedMonomial, map_mul, map_mul, map_pow, map_pow, + presentedWeylScalarExtension_previous] + rw [ih (fun i => a i.succ) (fun i => p i.succ)] + simp [presentedOrderedMonomial, presentedCoordinate, presentedMomentum] + +/-! ## The PBW-linear extension of coefficients -/ + +/-- Coefficient extension on the commutative symbol polynomial ring. -/ +def symbolScalarExtension (n : Nat) : + SymbolRing k n →ₐ[k] SymbolRing K n where + toRingHom := MvPolynomial.map (algebraMap k K) + commutes' := by + intro a + simp + +@[simp] theorem symbolScalarExtension_apply (n : Nat) (p : SymbolRing k n) : + symbolScalarExtension (k := k) (K := K) n p = + MvPolynomial.map (algebraMap k K) p := + rfl + +@[simp] theorem symbolScalarExtension_monomial (n : Nat) + (m : PhaseVar n →₀ ℕ) (a : k) : + symbolScalarExtension (k := k) (K := K) n + (MvPolynomial.monomial m a) = + MvPolynomial.monomial m (algebraMap k K a) := by + simp [MvPolynomial.map_monomial] + +/-- The `k`-linear map obtained by extending PBW coordinates and rebuilding in +the target presentation. -/ +def pbwScalarLinearMap (n : Nat) : + PresentedWeyl k n →ₗ[k] PresentedWeyl K n := + (presentedNormalFormLinearEquiv K n).symm.toLinearMap.restrictScalars k |>.comp + ((symbolScalarExtension (k := k) (K := K) n).toLinearMap.comp + (presentedNormalFormLinearEquiv k n).toLinearMap) + +@[simp] theorem pbwScalarLinearMap_basis (n : Nat) + (m : PhaseVar n →₀ ℕ) : + pbwScalarLinearMap (k := k) (K := K) n + (presentedPBWBasis k n m) = + presentedPBWBasis K n m := by + simp only [pbwScalarLinearMap, LinearMap.comp_apply] + change (presentedNormalFormLinearEquiv K n).symm + (symbolScalarExtension (k := k) (K := K) n + (presentedNormalFormLinearEquiv k n (presentedPBWBasis k n m))) = + presentedPBWBasis K n m + rw [presentedNormalFormLinearEquiv_basis, + symbolScalarExtension_monomial] + simp only [map_one] + rw [← presentedNormalFormBasis_apply] + rfl + +theorem presentedWeylScalarExtension_basis (n : Nat) + (m : PhaseVar n →₀ ℕ) : + presentedWeylScalarExtension (k := k) (K := K) n + (presentedPBWBasis k n m) = + presentedPBWBasis K n m := by + rw [presentedPBWBasis_apply, presentedPBWBasis_apply] + exact presentedWeylScalarExtension_orderedMonomial n + (fun i => m (.inl i)) (fun i => m (.inr i)) + +theorem presentedWeylScalarExtension_toLinearMap_eq_pbwScalarLinearMap + (n : Nat) : + (presentedWeylScalarExtension (k := k) (K := K) n).toLinearMap = + pbwScalarLinearMap (k := k) (K := K) n := by + apply Module.Basis.ext (presentedPBWBasis k n) + intro m + change presentedWeylScalarExtension (k := k) (K := K) n + (presentedPBWBasis k n m) = + pbwScalarLinearMap (k := k) (K := K) n + (presentedPBWBasis k n m) + rw [presentedWeylScalarExtension_basis, pbwScalarLinearMap_basis] + +theorem presentedNormalFormLinearEquiv_scalarExtension (n : Nat) + (z : PresentedWeyl k n) : + presentedNormalFormLinearEquiv K n + (presentedWeylScalarExtension (k := k) (K := K) n z) = + symbolScalarExtension (k := k) (K := K) n + (presentedNormalFormLinearEquiv k n z) := by + have hmap := DFunLike.congr_fun + (presentedWeylScalarExtension_toLinearMap_eq_pbwScalarLinearMap + (k := k) (K := K) n) z + change presentedWeylScalarExtension (k := k) (K := K) n z = + pbwScalarLinearMap (k := k) (K := K) n z at hmap + change presentedNormalFormLinearEquiv K n + (presentedWeylScalarExtension (k := k) (K := K) n z) = _ + rw [hmap] + simp [pbwScalarLinearMap, LinearMap.comp_apply] + +/-! ## Injectivity and filtered transport -/ + +theorem symbolScalarExtension_injective (n : Nat) : + Function.Injective (symbolScalarExtension (k := k) (K := K) n) := by + exact MvPolynomial.map_injective (algebraMap k K) + (FaithfulSMul.algebraMap_injective k K) + +theorem presentedWeylScalarExtension_injective (n : Nat) : + Function.Injective + (presentedWeylScalarExtension (k := k) (K := K) n) := by + intro a b hab + have hnorm := congrArg (presentedNormalFormLinearEquiv K n) hab + rw [presentedNormalFormLinearEquiv_scalarExtension, + presentedNormalFormLinearEquiv_scalarExtension] at hnorm + apply (presentedNormalFormLinearEquiv k n).injective + exact (symbolScalarExtension_injective (k := k) (K := K) n) hnorm + +theorem symbolScalarExtension_weightedHomogeneousComponent (n : Nat) + (w : PhaseVar n → ℕ) (N : ℕ) (f : SymbolRing k n) : + symbolScalarExtension (k := k) (K := K) n + (MvPolynomial.weightedHomogeneousComponent w N f) = + MvPolynomial.weightedHomogeneousComponent w N + (symbolScalarExtension (k := k) (K := K) n f) := by + classical + ext m + change MvPolynomial.coeff m + (MvPolynomial.map (algebraMap k K) + (MvPolynomial.weightedHomogeneousComponent w N f)) = + MvPolynomial.coeff m + (MvPolynomial.weightedHomogeneousComponent w N + (MvPolynomial.map (algebraMap k K) f)) + rw [MvPolynomial.coeff_map, + MvPolynomial.coeff_weightedHomogeneousComponent, + MvPolynomial.coeff_weightedHomogeneousComponent] + simp only [finsupp_weight_eq_monomialWeight] + by_cases hm : monomialWeight w m = N + · simp [hm] + rw [MvPolynomial.coeff_map] + · simp [hm] + +theorem presentedWeylScalarExtension_mem_weightPiece (n : Nat) + (w : PhaseVar n → ℕ) (N : ℕ) {z : PresentedWeyl k n} + (hz : z ∈ presentedWeightPiece k w N) : + presentedWeylScalarExtension (k := k) (K := K) n z ∈ + presentedWeightPiece K w N := by + rw [mem_presentedWeightPiece] at hz ⊢ + rw [presentedNormalFormLinearEquiv_scalarExtension + (k := k) (K := K) n z] + intro m hm + apply hz m + intro hzero + apply hm + simp [MvPolynomial.coeff_map, hzero] + +theorem presentedWeylScalarExtension_mem_orderPiece (n : Nat) + (N : ℕ) {z : PresentedWeyl k n} + (hz : z ∈ orderPiece k n N) : + presentedWeylScalarExtension (k := k) (K := K) n z ∈ + orderPiece K n N := by + exact presentedWeylScalarExtension_mem_weightPiece + (k := k) (K := K) n (@orderWeight n) N hz + +theorem presentedWeylScalarExtension_mem_bernsteinPiece (n : Nat) + (N : ℕ) {z : PresentedWeyl k n} + (hz : z ∈ bernsteinPiece k n N) : + presentedWeylScalarExtension (k := k) (K := K) n z ∈ + bernsteinPiece K n N := by + exact presentedWeylScalarExtension_mem_weightPiece + (k := k) (K := K) n (@bernsteinWeight n) N hz + +theorem presentedWeylScalarExtension_principalComponent (n : Nat) + (w : PhaseVar n → ℕ) (N : ℕ) (z : PresentedWeyl k n) : + symbolScalarExtension (k := k) (K := K) n + (presentedPrincipalComponent k w N z) = + presentedPrincipalComponent K w N + (presentedWeylScalarExtension (k := k) (K := K) n z) := by + change symbolScalarExtension (k := k) (K := K) n + (MvPolynomial.weightedHomogeneousComponent w N + (presentedNormalFormLinearEquiv k n z)) = + MvPolynomial.weightedHomogeneousComponent w N + (presentedNormalFormLinearEquiv K n + (presentedWeylScalarExtension (k := k) (K := K) n z)) + rw [presentedNormalFormLinearEquiv_scalarExtension] + exact symbolScalarExtension_weightedHomogeneousComponent + (k := k) (K := K) n w N + (presentedNormalFormLinearEquiv k n z) + +theorem presentedWeylScalarExtension_isPBWMonicAt (n : Nat) + (N : ℕ) {z : PresentedWeyl k (n + 1)} + (hz : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N z) : + IsPBWMonicAt K (.inr (0 : Fin (n + 1))) N + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) z) := by + refine ⟨presentedWeylScalarExtension_mem_bernsteinPiece + (k := k) (K := K) (n + 1) N hz.1, ?_⟩ + change MvPolynomial.coeff (Finsupp.single (.inr (0 : Fin (n + 1))) N) + (presentedNormalFormLinearEquiv K (n + 1) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) z)) = 1 + have hnorm := presentedNormalFormLinearEquiv_scalarExtension + (k := k) (K := K) (n + 1) z + rw [hnorm] + change MvPolynomial.coeff (Finsupp.single (.inr (0 : Fin (n + 1))) N) + (MvPolynomial.map (algebraMap k K) + (presentedNormalFormLinearEquiv k (n + 1) z)) = 1 + rw [MvPolynomial.coeff_map] + simp [hz.2] + +@[simp] theorem presentedWeylScalarExtension_coordinate (n : Nat) : + presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (presentedCoordinate k n) = presentedCoordinate K n := by + simp [presentedCoordinate] + +@[simp] theorem presentedWeylScalarExtension_momentum (n : Nat) : + presentedWeylScalarExtension (k := k) (K := K) (n + 1) + (presentedMomentum k n) = presentedMomentum K n := by + simp [presentedMomentum] + +theorem presentedWeylScalarExtension_mem_canonicalRightIdeal + (n N : Nat) {d : PresentedWeyl k (n + 1)} {z : PresentedWeyl k (n + 1)} + (hz : z ∈ canonicalRightIdeal (presentedCoordinate k n) d N) : + presentedWeylScalarExtension (k := k) (K := K) (n + 1) z ∈ + canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N := by + let e := presentedWeylScalarExtension (k := k) (K := K) (n + 1) + let J := canonicalRightIdeal (presentedCoordinate K n) (e d) N + change e z ∈ J + refine Submodule.span_induction ?_ ?_ ?_ ?_ hz + · intro a ha + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at ha + rcases ha with ha | ha + · subst a + exact firstGenerator_mem (presentedCoordinate K n) (e d) N + · subst a + simpa [e, J, map_mul, map_pow] using + (secondGenerator_mem (presentedCoordinate K n) (e d) N) + · simp [e, J] + · intro a b _ _ ha hb + simpa only [map_add] using J.add_mem ha hb + · intro c a _ ha + change e (a * c.unop) ∈ J + rw [map_mul] + change MulOpposite.op (e c.unop) • e a ∈ J + exact J.smul_mem _ ha + +/-! ## The safe initial-ideal comparison -/ + +/-- Every source order-initial generator maps to a target order-initial +generator. This is the comparison needed for descent; it is intentionally a +one-way inclusion and makes no claim that the target initial ideal is the +extension of the source initial ideal. -/ +theorem presentedWeylScalarExtension_map_orderInitialIdeal_le + (n N : Nat) (d : PresentedWeyl k (n + 1)) : + (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (symbolScalarExtension (k := k) (K := K) (n + 1)).toRingHom ≤ + orderInitialIdeal K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) := by + rw [Ideal.map_le_iff_le_comap] + apply Ideal.span_le.mpr + intro P hP + rcases hP with ⟨L, z, hz, hI, rfl⟩ + apply Ideal.subset_span + refine ⟨L, + presentedWeylScalarExtension (k := k) (K := K) (n + 1) z, ?_, ?_, ?_⟩ + · exact presentedWeylScalarExtension_mem_orderPiece + (k := k) (K := K) (n + 1) L hz + · exact presentedWeylScalarExtension_mem_canonicalRightIdeal + (k := k) (K := K) n N hI + · exact presentedWeylScalarExtension_principalComponent + (k := k) (K := K) (n + 1) orderWeight L z + +theorem target_orderCharacteristicSupport_subset_scalarExtended_zeroLocus + (n N : Nat) (d : PresentedWeyl k (n + 1)) : + orderCharacteristicSupport K + (canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N) ⊆ + PrimeSpectrum.zeroLocus + ((orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (symbolScalarExtension (k := k) (K := K) (n + 1)).toRingHom) := by + rw [orderCharacteristicSupport_eq_zeroLocus] + exact PrimeSpectrum.zeroLocus_anti_mono_ideal + (presentedWeylScalarExtension_map_orderInitialIdeal_le + (k := k) (K := K) n N d) + +/-! ## PBW spanning after scalar extension -/ + +/-- The `K`-linear span of the image of the quotient-presented scalar map. -/ +def scalarImageSpan (n : Nat) : + Submodule K (PresentedWeyl K n) := + Submodule.span K (Set.range + (presentedWeylScalarExtension (k := k) (K := K) n)) + +theorem target_mem_scalarImageSpan (n : Nat) (z : PresentedWeyl K n) : + z ∈ scalarImageSpan (k := k) (K := K) n := by + let f := presentedNormalFormLinearEquiv K n z + have hreconstruct : + z = ∑ m ∈ f.support, + MvPolynomial.coeff m f • presentedPBWBasis K n m := by + apply (presentedNormalFormLinearEquiv K n).injective + simp only [map_sum, map_smul, presentedNormalFormLinearEquiv_basis] + change f = _ + calc + f = ∑ m ∈ f.support, + MvPolynomial.monomial m (MvPolynomial.coeff m f) := + MvPolynomial.as_sum f + _ = _ := by + apply Finset.sum_congr rfl + intro m hm + rw [MvPolynomial.smul_monomial] + simp + rw [hreconstruct] + apply Submodule.sum_mem + intro m hm + apply Submodule.smul_mem + apply Submodule.subset_span + exact ⟨presentedPBWBasis k n m, + presentedWeylScalarExtension_basis (k := k) (K := K) n m⟩ + +/-- The `K`-linear span of the scalar extensions of a source right ideal. -/ +def scalarImageRightIdealSpan (n : Nat) + (I : RightIdeal (PresentedWeyl k n)) : + Submodule K (PresentedWeyl K n) := + Submodule.span K + (presentedWeylScalarExtension (k := k) (K := K) n '' + (I : Set (PresentedWeyl k n))) + +theorem scalarImageRightIdealSpan_mul_right (n : Nat) + (I : RightIdeal (PresentedWeyl k n)) + {a : PresentedWeyl K n} + (ha : a ∈ scalarImageRightIdealSpan (k := k) (K := K) n I) + (b : PresentedWeyl K n) : + a * b ∈ scalarImageRightIdealSpan (k := k) (K := K) n I := by + let e := presentedWeylScalarExtension (k := k) (K := K) n + let S := scalarImageRightIdealSpan (k := k) (K := K) n I + have hbase : ∀ (z : PresentedWeyl k n), z ∈ I → + ∀ b : PresentedWeyl K n, e z * b ∈ S := by + intro z hz b + have hb : b ∈ scalarImageSpan (k := k) (K := K) n := + target_mem_scalarImageSpan (k := k) (K := K) n b + refine Submodule.span_induction ?_ ?_ ?_ ?_ hb + · intro c hc + rcases hc with ⟨c, hc, rfl⟩ + have hzc : z * c ∈ I := by + change MulOpposite.op c • z ∈ I + exact I.smul_mem _ hz + change e z * e c ∈ S + rw [← map_mul] + exact Submodule.subset_span ⟨z * c, hzc, rfl⟩ + · simp [S, scalarImageRightIdealSpan] + · intro b₁ b₂ _ _ hb₁ hb₂ + simpa [mul_add] using S.add_mem hb₁ hb₂ + · intro c b _ hb + rw [Algebra.smul_def, ← mul_assoc, + (Algebra.commutes c (e z)).symm, mul_assoc] + simpa [Algebra.smul_def] using S.smul_mem c hb + refine Submodule.span_induction ?_ ?_ ?_ ?_ ha + · intro z hz + rcases hz with ⟨z, hz, rfl⟩ + exact hbase z hz b + · simp [S, scalarImageRightIdealSpan] + · intro a₁ a₂ _ _ ha₁ ha₂ + simpa [add_mul] using S.add_mem ha₁ ha₂ + · intro c a _ ha + rw [Algebra.smul_def, mul_assoc] + simpa [Algebra.smul_def] using S.smul_mem c ha + +theorem target_canonicalRightIdeal_le_scalarImageRightIdealSpan + (n N : Nat) (d : PresentedWeyl k (n + 1)) : + ∀ z, z ∈ canonicalRightIdeal (presentedCoordinate K n) + (presentedWeylScalarExtension (k := k) (K := K) (n + 1) d) N → + z ∈ scalarImageRightIdealSpan (k := k) (K := K) (n + 1) + (canonicalRightIdeal (presentedCoordinate k n) d N) := by + let e := presentedWeylScalarExtension (k := k) (K := K) (n + 1) + let I := canonicalRightIdeal (presentedCoordinate k n) d N + let S := scalarImageRightIdealSpan (k := k) (K := K) (n + 1) I + intro z hz + change z ∈ S + refine Submodule.span_induction ?_ ?_ ?_ ?_ hz + · intro a ha + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at ha + rcases ha with ha | ha + · subst a + change e d ∈ S + exact Submodule.subset_span ⟨d, firstGenerator_mem + (presentedCoordinate k n) d N, rfl⟩ + · subst a + change presentedCoordinate K n ^ N * e d ∈ S + rw [← presentedWeylScalarExtension_coordinate + (k := k) (K := K) n, ← map_pow, ← map_mul] + exact Submodule.subset_span ⟨presentedCoordinate k n ^ N * d, + secondGenerator_mem (presentedCoordinate k n) d N, rfl⟩ + · exact S.zero_mem + · intro a b _ _ ha hb + exact S.add_mem ha hb + · intro c a _ ha + change a * c.unop ∈ S + exact scalarImageRightIdealSpan_mul_right (k := k) (K := K) + (n + 1) I ha c.unop + +theorem scalarImageRightIdealSpan_eq_top (n : Nat) : + scalarImageRightIdealSpan (k := k) (K := K) n + (⊤ : RightIdeal (PresentedWeyl k n)) = ⊤ := by + apply top_unique + intro z _ + simpa [scalarImageRightIdealSpan, scalarImageSpan] using + (target_mem_scalarImageSpan (k := k) (K := K) n z) + +/-! ## The filtered lifting contract -/ + +theorem symbolScalarExtension_toRingHom (n : Nat) : + (symbolScalarExtension (k := k) (K := K) n).toRingHom = + scalarPolynomialMap (k := k) (K := K) (PhaseVar n) := rfl + +/-- The exact filtered statement for support descent. It asks that +every target order-initial generator be represented by the scalar extension +of source initial generators. It is stronger than the unfiltered PBW span +proved above and is deliberately not identified with a definitional +base-change equality. `FilteredScalarLifting.lean` proves this contract by +flat base change of the ideal/order-piece intersection. -/ +def FilteredInitialLifting : Prop := + ∀ (k : Type u) [Field k] [CharZero k] (n N : ℕ) + (d : PresentedWeyl k (n + 1)), + orderInitialIdeal (AlgebraicClosure k) + (canonicalRightIdeal (presentedCoordinate (AlgebraicClosure k) n) + (presentedWeylScalarExtension (k := k) + (K := AlgebraicClosure k) (n + 1) d) N) ≤ + (orderInitialIdeal k + (canonicalRightIdeal (presentedCoordinate k n) d N)).map + (scalarPolynomialMap (k := k) (K := AlgebraicClosure k) + (PhaseVar (n + 1))) + +theorem canonicalSupportDescent_of_filteredInitialLifting + (hfiltered : FilteredInitialLifting.{u}) : + Stafford38.CanonicalSupportVanishingReduction.CanonicalSupportDescent.{u} := by + intro hclosed + intro k _ _ n N d hN hd + let e := presentedWeylScalarExtension (k := k) + (K := AlgebraicClosure k) (n + 1) + let I := canonicalRightIdeal (presentedCoordinate k n) d N + let IK := canonicalRightIdeal (presentedCoordinate (AlgebraicClosure k) n) + (e d) N + have hdK : IsPBWMonicAt (AlgebraicClosure k) + (.inr (0 : Fin (n + 1))) N (e d) := by + exact presentedWeylScalarExtension_isPBWMonicAt + (k := k) (K := AlgebraicClosure k) n N hd + have hsupportK : orderCharacteristicSupport (AlgebraicClosure k) IK = ∅ := by + exact hclosed (AlgebraicClosure k) n N (e d) hN hdK + have htopK : orderInitialIdeal (AlgebraicClosure k) IK = ⊤ := + (orderCharacteristicSupport_eq_empty_iff (AlgebraicClosure k) IK).mp + hsupportK + have htopMap : + (orderInitialIdeal k I).map + (scalarPolynomialMap (k := k) (K := AlgebraicClosure k) + (PhaseVar (n + 1))) = ⊤ := by + apply top_unique + rw [← htopK] + exact hfiltered k n N d + have htop : orderInitialIdeal k I = ⊤ := by + exact (map_scalarPolynomialMap_eq_top_iff + (J := orderInitialIdeal k I)).mp htopMap + exact (orderCharacteristicSupport_eq_empty_iff k I).mpr htop + + +end + +end Stafford38.Weyl.PresentedScalarExtension diff --git a/LeanPool/Stafford38/Stafford38/Weyl/QuotientTransport.lean b/LeanPool/Stafford38/Stafford38/Weyl/QuotientTransport.lean new file mode 100644 index 0000000000..fcd377ff8b --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/QuotientTransport.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Quotient.EulerSurjectivity +import LeanPool.Stafford38.Stafford38.Weyl.EulerRemainder +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence + +/-! +# Transport of the canonical right quotient + +The recursive Ore tower and the presented Weyl algebra are related by an +algebra equivalence. This file transports the *literal* two-generator right +ideal and its right quotient across that equivalence. The final theorem is +the presented-Weyl form of the already proved `PairStage` surjectivity. +-/ + +namespace Stafford38.WeylQuotientTransport + +open Stafford38.EulerSurjectivity +open Stafford38.OreIteratedPairStage +open Stafford38.OrePairStage +open Stafford38.WeylEulerRemainder +open Stafford38.WeylEulerResidue +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylPBWMonicBridge +open Stafford38.WeylUniversal + +noncomputable section + +universe u + +variable {k : Type u} [Field k] + +/-! ## Right-module transport -/ + +instance rightModuleEquiv_invPair {A B : Type*} [Ring A] [Ring B] + [Algebra k A] [Algebra k B] (e : A ≃ₐ[k] B) : + RingHomInvPair + ((AlgEquiv.op e).toRingEquiv : Aᵐᵒᵖ →+* Bᵐᵒᵖ) + ((AlgEquiv.op e).toRingEquiv.symm : Bᵐᵒᵖ →+* Aᵐᵒᵖ) := + RingHomInvPair.of_ringEquiv (AlgEquiv.op e).toRingEquiv + +instance rightModuleEquiv_invPair_symm {A B : Type*} [Ring A] [Ring B] + [Algebra k A] [Algebra k B] (e : A ≃ₐ[k] B) : + RingHomInvPair + ((AlgEquiv.op e).toRingEquiv.symm : Bᵐᵒᵖ →+* Aᵐᵒᵖ) + ((AlgEquiv.op e).toRingEquiv : Aᵐᵒᵖ →+* Bᵐᵒᵖ) := + RingHomInvPair.of_ringEquiv (AlgEquiv.op e).toRingEquiv.symm + +/-- The algebra equivalence, regarded as a semilinear equivalence of regular +right modules. The scalar ring is transported on opposites. -/ +def rightModuleEquiv {A B : Type*} [Ring A] [Ring B] [Algebra k A] + [Algebra k B] (e : A ≃ₐ[k] B) : + @LinearEquiv Aᵐᵒᵖ Bᵐᵒᵖ _ _ (AlgEquiv.op e).toRingEquiv + (AlgEquiv.op e).toRingEquiv.symm _ _ A B _ _ _ _ := + { e.toAddEquiv with + map_smul' := by + intro c a + change e (a * c.unop) = e a * e c.unop + exact map_mul e a c.unop } + +/-- The inverse regular-right-module equivalence, with the inverse opposite +scalar map made explicit for quotient composition. -/ +def rightModuleEquiv_symm {A B : Type*} [Ring A] [Ring B] [Algebra k A] + [Algebra k B] (e : A ≃ₐ[k] B) : + @LinearEquiv Bᵐᵒᵖ Aᵐᵒᵖ _ _ (AlgEquiv.op e).toRingEquiv.symm + (AlgEquiv.op e).toRingEquiv _ _ B A _ _ _ _ := + { e.symm.toAddEquiv with + map_smul' := by + intro c b + change e.symm (b * c.unop) = e.symm b * e.symm c.unop + exact map_mul e.symm b c.unop } + +/-- Image transport of a literal right ideal along an algebra equivalence. -/ +def transportedRightIdeal {A B : Type*} [Ring A] [Ring B] [Algebra k A] + [Algebra k B] (e : A ≃ₐ[k] B) (I : RightIdeal A) : RightIdeal B := + { carrier := e '' I + zero_mem' := by + exact ⟨0, I.zero_mem, by simp⟩ + add_mem' := by + rintro y z ⟨y', hy', rfl⟩ ⟨z', hz', rfl⟩ + refine ⟨y' + z', I.add_mem hy' hz', ?_⟩ + simp + smul_mem' := by + rintro b y ⟨a, ha, rfl⟩ + let c : Aᵐᵒᵖ := (AlgEquiv.op e).symm b + refine ⟨c • a, I.smul_mem c ha, ?_⟩ + have h := (rightModuleEquiv e).map_smulₛₗ c a + calc + e (c • a) = (AlgEquiv.op e).toRingEquiv c • e a := h + _ = b • e a := by + rw [show (AlgEquiv.op e).toRingEquiv c = b by + exact (AlgEquiv.op e).apply_symm_apply b] } + +/-! ## The two generators and quotient -/ + +/-- The literal canonical right ideal in the presented Weyl algebra. -/ +def presentedCanonicalRightIdeal (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + RightIdeal (PresentedWeyl k (n + 1)) := + canonicalRightIdeal (presentedCoordinate k n) d N + +/-- Its literal right quotient. -/ +abbrev PresentedCanonicalRightQuotient (n N : ℕ) + (d : PresentedWeyl k (n + 1)) := + RightQuotient (presentedCanonicalRightIdeal (k := k) n N d) + +theorem transported_canonicalRightIdeal + {A B : Type*} [Ring A] [Ring B] [Algebra k A] [Algebra k B] + (e : A ≃ₐ[k] B) (x d : A) (N : ℕ) : + transportedRightIdeal e (canonicalRightIdeal x d N) = + canonicalRightIdeal (e x) (e d) N := by + apply le_antisymm + · intro y hy + change y ∈ e '' canonicalRightIdeal x d N at hy + rcases hy with ⟨z, hz, rfl⟩ + refine Submodule.span_induction ?_ ?_ ?_ ?_ hz + · intro z hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hz + rcases hz with hz | hz + · subst z + exact firstGenerator_mem (e x) (e d) N + · subst z + simpa [map_mul, map_pow] using + (secondGenerator_mem (e x) (e d) N) + · simp + · intro a b ha hb hha hhb + simpa using (canonicalRightIdeal (e x) (e d) N).add_mem hha hhb + · intro c a ha hha + change (rightModuleEquiv e) (c • a) ∈ + canonicalRightIdeal (e x) (e d) N + rw [(rightModuleEquiv e).map_smulₛₗ c a] + exact (canonicalRightIdeal (e x) (e d) N).smul_mem _ hha + · intro y hy + change y ∈ e '' canonicalRightIdeal x d N + refine ⟨e.symm y, ?_, by simp⟩ + refine Submodule.span_induction ?_ ?_ ?_ ?_ hy + · intro z hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hz + rcases hz with hz | hz + · subst z + simpa using (firstGenerator_mem x d N) + · subst z + simpa [map_mul, map_pow] using (secondGenerator_mem x d N) + · simp + · intro a b ha hb hha hhb + simpa using (canonicalRightIdeal x d N).add_mem hha hhb + · intro c a ha hha + change (rightModuleEquiv_symm e) (c • a) ∈ + canonicalRightIdeal x d N + rw [(rightModuleEquiv_symm e).map_smulₛₗ c a] + exact (canonicalRightIdeal x d N).smul_mem _ hha + +theorem presented_canonicalRightIdeal_map + (n N : ℕ) (d : PresentedWeyl k (n + 1)) : + transportedRightIdeal (presentedIteratedEquiv k (n + 1)) + (presentedCanonicalRightIdeal (k := k) n N d) = + canonicalRightIdeal (pairCoordinate (B := IteratedPairStage k n)) + (presentedToIterated k (n + 1) d) N := by + have h := transported_canonicalRightIdeal + (e := presentedIteratedEquiv k (n + 1)) + (x := presentedCoordinate k n) (d := d) (N := N) + change transportedRightIdeal (presentedIteratedEquiv k (n + 1)) + (canonicalRightIdeal (presentedCoordinate k n) d N) = _ + have hx : presentedIteratedEquiv k (n + 1) (presentedCoordinate k n) = + pairCoordinate (B := IteratedPairStage k n) := by + change presentedToIterated k (n + 1) (presentedCoordinate k n) = + pairCoordinate (B := IteratedPairStage k n) + simpa only [stageCoordinate] using (presentedToIterated_coordinate k n) + rw [hx] at h + exact h + +/-- The quotient map induced by the transported ideal. -/ +def transportedRightQuotientMap {A B : Type*} [Ring A] [Ring B] + [Algebra k A] [Algebra k B] (e : A ≃ₐ[k] B) (I : RightIdeal A) : + @LinearMap Aᵐᵒᵖ Bᵐᵒᵖ _ _ (AlgEquiv.op e).toRingEquiv + (RightQuotient I) (RightQuotient (transportedRightIdeal e I)) _ _ _ _ := + Submodule.mapQ I (transportedRightIdeal e I) (rightModuleEquiv e) (by + intro a ha + exact ⟨a, ha, by rfl⟩) + +@[simp] theorem transportedRightQuotientMap_qmk + {A B : Type*} [Ring A] [Ring B] [Algebra k A] [Algebra k B] + (e : A ≃ₐ[k] B) (I : RightIdeal A) (a : A) : + transportedRightQuotientMap e I (qmk I a) = + qmk (transportedRightIdeal e I) (e a) := by + rfl + +/-- The quotient equivalence induced by the transported ideal. -/ +def transportedRightQuotientEquiv {A B : Type*} [Ring A] [Ring B] + [Algebra k A] [Algebra k B] (e : A ≃ₐ[k] B) (I : RightIdeal A) : + @LinearEquiv Aᵐᵒᵖ Bᵐᵒᵖ _ _ (AlgEquiv.op e).toRingEquiv + (AlgEquiv.op e).toRingEquiv.symm _ _ + (RightQuotient I) (RightQuotient (transportedRightIdeal e I)) _ _ _ _ := by + apply LinearEquiv.ofLinear (transportedRightQuotientMap e I) + (Submodule.mapQ (transportedRightIdeal e I) I + (rightModuleEquiv_symm e) (by + intro b hb + change b ∈ e '' I at hb + rcases hb with ⟨a, ha, rfl⟩ + simpa [rightModuleEquiv_symm] using ha)) + · apply LinearMap.ext + intro q + refine Submodule.Quotient.induction_on + (transportedRightIdeal e I) q ?_ + intro b + change transportedRightQuotientMap e I + (qmk I (e.symm b)) = qmk (transportedRightIdeal e I) b + rw [transportedRightQuotientMap_qmk] + simp + · apply LinearMap.ext + intro q + refine Submodule.Quotient.induction_on I q ?_ + intro a + simp only [LinearMap.coe_comp, Function.comp_apply] + change qmk I (e.symm (e a)) = qmk I a + simp + +@[simp] theorem transportedRightQuotientEquiv_qmk + {A B : Type*} [Ring A] [Ring B] [Algebra k A] [Algebra k B] + (e : A ≃ₐ[k] B) (I : RightIdeal A) (a : A) : + transportedRightQuotientEquiv e I (qmk I a) = + qmk (transportedRightIdeal e I) (e a) := rfl + +theorem transportedRightQuotientEquiv_rightMul + {A B : Type*} [Ring A] [Ring B] [Algebra k A] [Algebra k B] + (e : A ≃ₐ[k] B) (I : RightIdeal A) (a : A) (q : RightQuotient I) : + transportedRightQuotientEquiv e I (rightMul I a q) = + rightMul (transportedRightIdeal e I) (e a) + (transportedRightQuotientEquiv e I q) := by + refine Submodule.Quotient.induction_on I q ?_ + intro b + change transportedRightQuotientEquiv e I + (MulOpposite.op a • Submodule.Quotient.mk b) = _ + rw [LinearEquiv.map_smulₛₗ] + rfl + +/-! ## Presented-Weyl surjectivity -/ + +theorem presentedCanonicalRightQuotient_rightMul_coordinate_surjective + [Algebra ℚ k] (n N : ℕ) {d : PresentedWeyl k (n + 1)} + (hd : IsPBWMonicAt k (.inr (0 : Fin (n + 1))) N d) : + Function.Surjective + (rightMul (presentedCanonicalRightIdeal (k := k) n N d) + (presentedCoordinate k n)) := by + let e := presentedIteratedEquiv k (n + 1) + let I := presentedCanonicalRightIdeal (k := k) n N d + let f := transportedRightQuotientEquiv e I + have hmap : transportedRightIdeal e I = + canonicalRightIdeal (pairCoordinate (B := IteratedPairStage k n)) + (presentedToIterated k (n + 1) d) N := by + exact presented_canonicalRightIdeal_map (k := k) n N d + have hsurj := presentedCanonicalQuotient_rightMul_coordinate_surjective + k n N hd + have hsurj' : Function.Surjective + (rightMul (transportedRightIdeal e I) + (e (presentedCoordinate k n))) := by + rw [hmap] + have hx : e (presentedCoordinate k n) = + pairCoordinate (B := IteratedPairStage k n) := by + change presentedToIterated k (n + 1) (presentedCoordinate k n) = + pairCoordinate (B := IteratedPairStage k n) + simpa only [stageCoordinate] using (presentedToIterated_coordinate k n) + rw [hx] + exact hsurj + intro q + obtain ⟨r, hr⟩ := hsurj' (f q) + refine ⟨f.symm r, ?_⟩ + apply f.injective + rw [transportedRightQuotientEquiv_rightMul] + rw [f.apply_symm_apply] + exact hr + + +end +end Stafford38.WeylQuotientTransport diff --git a/LeanPool/Stafford38/Stafford38/Weyl/SymbolCompatibility.lean b/LeanPool/Stafford38/Stafford38/Weyl/SymbolCompatibility.lean new file mode 100644 index 0000000000..eb096049f3 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/SymbolCompatibility.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Weyl.Symplectic +import LeanPool.Stafford38.Stafford38.Weyl.LeadingSymbol +import LeanPool.Stafford38.Stafford38.Characteristic.LinearAction + +/-! +# Bernstein-symbol compatibility for linear Weyl changes + +An algebra map whose generator images have Bernstein degree one preserves the +Bernstein filtration. Its action on every principal component is obtained by +commutatively substituting the degree-one principal symbols of those images. +For a symplectic linear Weyl map, this induced substitution is exactly the +phase-space linear action defined in `Characteristic.LinearAction`. +-/ + +namespace Stafford38.WeylSymbolCompatibility + +open Stafford +open AlgebraicAnalysis +open Stafford38.Characteristic +open Stafford38.CharacteristicLinearAction +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW +open Stafford38.WeylSymplectic + +noncomputable section + +universe u +variable (k : Type u) [Field k] + +theorem normalForm_linearCombination {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + presentedNormalFormLinearEquiv k n + (freeWeylLinearCombination M + (freeWeylGenerator (standardForm k n)) i) = + symbolLinearCombination k M i := by + calc + _ = presentedNormalFormLinearEquiv k n + (∑ j, (M i j) • freeWeylGenerator (standardForm k n) j) := by + congr 1 + _ = ∑ j, (M i j) • MvPolynomial.X j := by + rw [map_sum] + apply Finset.sum_congr rfl + intro j hj + rw [map_smul, presentedNormalFormLinearEquiv_generator] + _ = _ := by + simp [symbolLinearCombination, Algebra.smul_def] + +theorem linearCombination_mem_bernsteinPiece {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + freeWeylLinearCombination M + (freeWeylGenerator (standardForm k n)) i ∈ + bernsteinPiece k n 1 := by + rw [freeWeylLinearCombination] + apply Submodule.sum_mem + intro j hj + rw [← Algebra.smul_def] + apply Submodule.smul_mem + rw [bernsteinPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X, ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight, bernsteinWeight] at hweight) + +theorem principal_linearCombination {n : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) (i : PhaseVar n) : + presentedPrincipalComponent k (@bernsteinWeight n) 1 + (freeWeylLinearCombination M + (freeWeylGenerator (standardForm k n)) i) = + symbolLinearCombination k M i := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, normalForm_linearCombination] + rw [symbolLinearCombination, map_sum] + apply Finset.sum_congr rfl + intro j hj + rw [MvPolynomial.weightedHomogeneousComponent_C_mul] + congr 1 + conv_lhs => rw [← pow_one (MvPolynomial.X j), MvPolynomial.X_pow_eq_monomial] + conv_rhs => rw [← pow_one (MvPolynomial.X j), MvPolynomial.X_pow_eq_monomial] + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, bernsteinWeight] + +theorem one_mem_bernsteinPiece (r : ℕ) : + (1 : PresentedWeyl k r) ∈ bernsteinPiece k r 0 := by + rw [bernsteinPiece, mem_presentedWeightPiece, + presentedNormalFormLinearEquiv_one] + intro m hm + simp only [MvPolynomial.coeff_one, ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight] at hweight) + +theorem pow_mem_bernsteinPiece {r : ℕ} {x : PresentedWeyl k r} + (hx : x ∈ bernsteinPiece k r 1) : + ∀ a : ℕ, x ^ a ∈ bernsteinPiece k r a + | 0 => by simpa using one_mem_bernsteinPiece k r + | a + 1 => by + rw [pow_succ] + simpa [Nat.add_comm] using + mul_mem_bernsteinPiece k (pow_mem_bernsteinPiece hx a) hx + +theorem algHom_orderedMonomial_mem_bernstein + {r : ℕ} (f : PresentedWeyl k 0 →ₐ[k] PresentedWeyl k r) + (_hgen : ∀ i : PhaseVar 0, + f (freeWeylGenerator (standardForm k 0) i) ∈ + bernsteinPiece k r 1) + (a p : Fin 0 → ℕ) : + f (presentedOrderedMonomial k 0 a p) ∈ + bernsteinPiece k r + (monomialWeight (@bernsteinWeight 0) (phaseExponent a p)) := by + simp only [presentedOrderedMonomial, map_one] + have hw : monomialWeight (@bernsteinWeight 0) (phaseExponent a p) = 0 := by + have hphase : phaseExponent a p = 0 := by + ext i + cases i with + | inl i => exact Fin.elim0 i + | inr i => exact Fin.elim0 i + rw [hphase] + rfl + rw [hw] + exact one_mem_bernsteinPiece k r + +theorem algHom_orderedMonomial_mem_bernstein_succ + {n r : ℕ} + (ih : ∀ (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r), + (∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) → + ∀ (a p : Fin n → ℕ), + f (presentedOrderedMonomial k n a p) ∈ + bernsteinPiece k r + (monomialWeight (@bernsteinWeight n) (phaseExponent a p))) + (f : PresentedWeyl k (n + 1) →ₐ[k] PresentedWeyl k r) + (hgen : ∀ i : PhaseVar (n + 1), + f (freeWeylGenerator (standardForm k (n + 1)) i) ∈ + bernsteinPiece k r 1) + (a p : Fin (n + 1) → ℕ) : + f (presentedOrderedMonomial k (n + 1) a p) ∈ + bernsteinPiece k r + (monomialWeight (@bernsteinWeight (n + 1)) (phaseExponent a p)) := by + let fold : PresentedWeyl k n →ₐ[k] PresentedWeyl k r := + f.comp (previousWeylEmbedding k n) + have hfold : ∀ i : PhaseVar n, + fold (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1 := by + intro i + simpa [fold, oldGenerator] using hgen (oldIndex i) + have hold := ih fold hfold (fun i => a i.succ) (fun i => p i.succ) + have hx := pow_mem_bernsteinPiece k (hgen (.inl 0)) (a 0) + have hp := pow_mem_bernsteinPiece k (hgen (.inr 0)) (p 0) + have hmul := mul_mem_bernsteinPiece k + (mul_mem_bernsteinPiece k hold hx) hp + change f ((previousWeylEmbedding k n) + (presentedOrderedMonomial k n (fun i => a i.succ) (fun i => p i.succ))) * + f (presentedCoordinate k n) ^ a 0 * + f (presentedMomentum k n) ^ p 0 ∈ _ at hmul + rw [presentedOrderedMonomial, map_mul, map_mul, map_pow, map_pow] + rw [monomialWeight_phaseExponent_succ_bernstein] + simpa [fold, add_assoc] using hmul + +theorem algHom_orderedMonomial_mem_bernstein_all {r : ℕ} : + ∀ (n : ℕ) (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r), + (∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) → + ∀ (a p : Fin n → ℕ), + f (presentedOrderedMonomial k n a p) ∈ + bernsteinPiece k r + (monomialWeight (@bernsteinWeight n) (phaseExponent a p)) + | 0 => algHom_orderedMonomial_mem_bernstein k + | n + 1 => algHom_orderedMonomial_mem_bernstein_succ k + (algHom_orderedMonomial_mem_bernstein_all n) + +theorem algHom_preserves_bernsteinPiece {n r N : ℕ} + (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r) + (hgen : ∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + f z ∈ bernsteinPiece k r N := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at hz + induction hz using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + rw [presentedPBWBasis_apply] + have h := algHom_orderedMonomial_mem_bernstein_all k n f hgen + (fun i => m (.inl i)) (fun i => m (.inr i)) + rw [phaseExponent_split] at h + exact presentedWeightPiece_mono k bernsteinWeight hm h + | zero => + rw [map_zero] + exact (bernsteinPiece k r N).zero_mem + | add x y hx hy ihx ihy => + rw [map_add] + exact (bernsteinPiece k r N).add_mem ihx ihy + | smul c x hx ih => + rw [map_smul] + exact (bernsteinPiece k r N).smul_mem c ih + +theorem standardSymplecticAlgHom_preserves_bernsteinPiece {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + standardSymplecticAlgHom k M hM z ∈ bernsteinPiece k n N := by + exact algHom_preserves_bernsteinPiece k + (standardSymplecticAlgHom k M hM) + (fun i => by + rw [standardSymplecticAlgHom_generator] + exact linearCombination_mem_bernsteinPiece k M i) hz + +theorem phaseMonomial_succ_decompose {n : ℕ} + (a p : Fin (n + 1) → ℕ) : + MvPolynomial.monomial (phaseExponent a p) (1 : k) = + MvPolynomial.rename oldIndex + (MvPolynomial.monomial + (phaseExponent (fun i => a i.succ) (fun i => p i.succ)) 1) * + MvPolynomial.X (.inl (0 : Fin (n + 1))) ^ a 0 * + MvPolynomial.X (.inr (0 : Fin (n + 1))) ^ p 0 := by + rw [phaseExponent_succ_eq_extend, extendPhaseExponent, + MvPolynomial.rename_monomial, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.X_pow_eq_monomial, + MvPolynomial.monomial_mul, MvPolynomial.monomial_mul] + simp [add_comm, add_left_comm, add_assoc] + +theorem principal_one_bernstein (r : ℕ) : + presentedPrincipalComponent k (@bernsteinWeight r) 0 + (1 : PresentedWeyl k r) = 1 := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, presentedNormalFormLinearEquiv_one] + change MvPolynomial.weightedHomogeneousComponent (@bernsteinWeight r) 0 + (MvPolynomial.monomial (0 : PhaseVar r →₀ ℕ) (1 : k)) = 1 + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight] + +theorem pow_principal_bernstein {r : ℕ} {x : PresentedWeyl k r} + (hx : x ∈ bernsteinPiece k r 1) : + ∀ a : ℕ, + presentedPrincipalComponent k (@bernsteinWeight r) a (x ^ a) = + (presentedPrincipalComponent k (@bernsteinWeight r) 1 x) ^ a + | 0 => by simpa using principal_one_bernstein k r + | a + 1 => by + rw [pow_succ, pow_succ, ← pow_principal_bernstein hx a] + simpa [Nat.add_comm] using + presentedPrincipalComponent_mul_bernstein k + (pow_mem_bernsteinPiece k hx a) hx + +theorem algHom_orderedMonomial_principal_zero + {r : ℕ} (f : PresentedWeyl k 0 →ₐ[k] PresentedWeyl k r) + (g : PhaseVar 0 → SymbolRing k r) + (a p : Fin 0 → ℕ) : + presentedPrincipalComponent k (@bernsteinWeight r) + (monomialWeight (@bernsteinWeight 0) (phaseExponent a p)) + (f (presentedOrderedMonomial k 0 a p)) = + MvPolynomial.aeval g + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) := by + have hphase : phaseExponent a p = 0 := by + ext i + cases i with + | inl i => exact Fin.elim0 i + | inr i => exact Fin.elim0 i + rw [hphase] + simp [presentedOrderedMonomial, principal_one_bernstein, monomialWeight] + +theorem algHom_orderedMonomial_principal_succ + {n r : ℕ} + (ih : ∀ (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r) + (_hgen : ∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) + (g : PhaseVar n → SymbolRing k r), + (∀ i, + presentedPrincipalComponent k (@bernsteinWeight r) 1 + (f (freeWeylGenerator (standardForm k n) i)) = g i) → + ∀ (a p : Fin n → ℕ), + presentedPrincipalComponent k (@bernsteinWeight r) + (monomialWeight (@bernsteinWeight n) (phaseExponent a p)) + (f (presentedOrderedMonomial k n a p)) = + MvPolynomial.aeval g + (MvPolynomial.monomial (phaseExponent a p) (1 : k))) + (f : PresentedWeyl k (n + 1) →ₐ[k] PresentedWeyl k r) + (hgen : ∀ i : PhaseVar (n + 1), + f (freeWeylGenerator (standardForm k (n + 1)) i) ∈ + bernsteinPiece k r 1) + (g : PhaseVar (n + 1) → SymbolRing k r) + (hprincipal : ∀ i, + presentedPrincipalComponent k (@bernsteinWeight r) 1 + (f (freeWeylGenerator (standardForm k (n + 1)) i)) = g i) + (a p : Fin (n + 1) → ℕ) : + presentedPrincipalComponent k (@bernsteinWeight r) + (monomialWeight (@bernsteinWeight (n + 1)) (phaseExponent a p)) + (f (presentedOrderedMonomial k (n + 1) a p)) = + MvPolynomial.aeval g + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) := by + let fold : PresentedWeyl k n →ₐ[k] PresentedWeyl k r := + f.comp (previousWeylEmbedding k n) + let gold : PhaseVar n → SymbolRing k r := fun i => g (oldIndex i) + have hfold : ∀ i : PhaseVar n, + fold (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1 := by + intro i + simpa [fold, oldGenerator] using hgen (oldIndex i) + have hfoldprincipal : ∀ i, + presentedPrincipalComponent k (@bernsteinWeight r) 1 + (fold (freeWeylGenerator (standardForm k n) i)) = gold i := by + intro i + simpa [fold, gold, oldGenerator] using hprincipal (oldIndex i) + let aold : Fin n → ℕ := fun i => a i.succ + let pold : Fin n → ℕ := fun i => p i.succ + let d := monomialWeight (@bernsteinWeight n) (phaseExponent aold pold) + have holdmem := algHom_orderedMonomial_mem_bernstein_all k n fold hfold aold pold + have holdprincipal := ih fold hfold gold hfoldprincipal aold pold + have hx := hgen (.inl 0) + have hp := hgen (.inr 0) + have hxa := pow_mem_bernsteinPiece k hx (a 0) + have hpp := pow_mem_bernsteinPiece k hp (p 0) + have hfirst := presentedPrincipalComponent_mul_bernstein k holdmem hxa + rw [pow_principal_bernstein k hx] at hfirst + have hfirstmem := mul_mem_bernsteinPiece k holdmem hxa + have hsecond := presentedPrincipalComponent_mul_bernstein k hfirstmem hpp + rw [pow_principal_bernstein k hp, hfirst, holdprincipal, + hprincipal (.inl 0), hprincipal (.inr 0)] at hsecond + have hf : f (presentedOrderedMonomial k (n + 1) a p) = + fold (presentedOrderedMonomial k n aold pold) * + f (presentedCoordinate k n) ^ a 0 * + f (presentedMomentum k n) ^ p 0 := by + rw [presentedOrderedMonomial, map_mul, map_mul, map_pow, map_pow] + rfl + rw [hf, monomialWeight_phaseExponent_succ_bernstein] + change presentedPrincipalComponent k (@bernsteinWeight r) + (d + a 0 + p 0) + (fold (presentedOrderedMonomial k n aold pold) * + f (presentedCoordinate k n) ^ a 0 * + f (presentedMomentum k n) ^ p 0) = _ + rw [phaseMonomial_succ_decompose] + simp only [map_mul, map_pow, MvPolynomial.aeval_X] + rw [MvPolynomial.aeval_rename] + exact hsecond + +theorem algHom_orderedMonomial_principal_all {r : ℕ} : + ∀ (n : ℕ) (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r) + (_hgen : ∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) + (g : PhaseVar n → SymbolRing k r), + (∀ i, + presentedPrincipalComponent k (@bernsteinWeight r) 1 + (f (freeWeylGenerator (standardForm k n) i)) = g i) → + ∀ (a p : Fin n → ℕ), + presentedPrincipalComponent k (@bernsteinWeight r) + (monomialWeight (@bernsteinWeight n) (phaseExponent a p)) + (f (presentedOrderedMonomial k n a p)) = + MvPolynomial.aeval g + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) + | 0 => fun f _ g _ => algHom_orderedMonomial_principal_zero k f g + | n + 1 => algHom_orderedMonomial_principal_succ k + (algHom_orderedMonomial_principal_all n) + +theorem algHom_principal_compatibility {n r N : ℕ} + (f : PresentedWeyl k n →ₐ[k] PresentedWeyl k r) + (hgen : ∀ i : PhaseVar n, + f (freeWeylGenerator (standardForm k n) i) ∈ + bernsteinPiece k r 1) + (g : PhaseVar n → SymbolRing k r) + (hprincipal : ∀ i, + presentedPrincipalComponent k (@bernsteinWeight r) 1 + (f (freeWeylGenerator (standardForm k n) i)) = g i) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + presentedPrincipalComponent k (@bernsteinWeight r) N (f z) = + MvPolynomial.aeval g + (presentedPrincipalComponent k (@bernsteinWeight n) N z) := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at hz + induction hz using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + let d := monomialWeight (@bernsteinWeight n) m + have hmapmem : f (presentedPBWBasis k n m) ∈ bernsteinPiece k r d := by + rw [presentedPBWBasis_apply] + have h := algHom_orderedMonomial_mem_bernstein_all k n f hgen + (fun i => m (.inl i)) (fun i => m (.inr i)) + rw [phaseExponent_split] at h + exact h + by_cases hd : d = N + · subst N + rw [presentedPrincipalComponent_basis, if_pos rfl, + presentedPBWBasis_apply] + have h := algHom_orderedMonomial_principal_all k n f hgen g hprincipal + (fun i => m (.inl i)) (fun i => m (.inr i)) + rw [phaseExponent_split] at h + exact h + · have hdlt : d < N := lt_of_le_of_ne hm hd + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + (@bernsteinWeight r) (f (presentedPBWBasis k n m)) hmapmem hdlt, + presentedPrincipalComponent_basis, if_neg hd, map_zero] + | zero => simp + | add x y hx hy ihx ihy => + simp only [map_add] + rw [ihx, ihy] + | smul c x hx ih => + simp only [map_smul] + rw [ih] + +theorem standardSymplecticAlgHom_principal_compatibility {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + presentedPrincipalComponent k (@bernsteinWeight n) N + (standardSymplecticAlgHom k M hM z) = + symbolLinearAlgHom k M + (presentedPrincipalComponent k (@bernsteinWeight n) N z) := by + exact algHom_principal_compatibility k + (standardSymplecticAlgHom k M hM) + (fun i => by + rw [standardSymplecticAlgHom_generator] + exact linearCombination_mem_bernsteinPiece k M i) + (symbolLinearCombination k M) + (fun i => by + rw [standardSymplecticAlgHom_generator] + exact principal_linearCombination k M i) hz + +/- Exact statement pins for the two exported compatibility conclusions. -/ +example {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + standardSymplecticAlgHom k M hM z ∈ bernsteinPiece k n N := + standardSymplecticAlgHom_preserves_bernsteinPiece k M hM hz + +example {n N : ℕ} + (M : Matrix (PhaseVar n) (PhaseVar n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + {z : PresentedWeyl k n} (hz : z ∈ bernsteinPiece k n N) : + presentedPrincipalComponent k (@bernsteinWeight n) N + (standardSymplecticAlgHom k M hM z) = + symbolLinearAlgHom k M + (presentedPrincipalComponent k (@bernsteinWeight n) N z) := + standardSymplecticAlgHom_principal_compatibility k M hM hz + + +end +end Stafford38.WeylSymbolCompatibility diff --git a/LeanPool/Stafford38/Stafford38/Weyl/Symplectic.lean b/LeanPool/Stafford38/Stafford38/Weyl/Symplectic.lean new file mode 100644 index 0000000000..bae6824925 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/Symplectic.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.proofs.weyl_symplectic + +/-! +# General-rank linear symplectic changes of Weyl generators + +A matrix preserving the standard symplectic form defines an algebra +endomorphism of the presented Weyl algebra. Two form-preserving matrices that +are mutual inverses define a checked algebra equivalence. The inverse is part +of the input, which keeps this theorem independent of matrix inversion APIs +and makes the exact direction of generator substitution explicit. +-/ + +namespace Stafford38.WeylSymplectic + +open Stafford +open AlgebraicAnalysis + +noncomputable section + +universe u + +variable (k : Type u) [Field k] + +abbrev standardForm (n : ℕ) : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k := + Matrix.J (Fin n) k + +def standardSymplecticHpres {n : ℕ} + (M : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) : + ∀ i j, + Stafford.commutator + (freeWeylLinearCombination M + (freeWeylGenerator (standardForm k n)) i) + (freeWeylLinearCombination M + (freeWeylGenerator (standardForm k n)) j) = + algebraMap k (FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n)) + (standardForm k n i j) := by + exact symplectic_linear_change_preserves_commutator M + (freeWeylGenerator (standardForm k n)) (standardForm k n) + (fun i j => freeWeylGenerator_commutator (standardForm k n) i j) hM + +def standardSymplecticAlgHom {n : ℕ} + (M : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) : + FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n) →ₐ[k] + FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n) := + freeWeylSymplecticAlgHom M (standardForm k n) + (standardSymplecticHpres k M hM) + +@[simp] theorem standardSymplecticAlgHom_generator {n : ℕ} + (M : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (i : Fin n ⊕ Fin n) : + standardSymplecticAlgHom k M hM + (freeWeylGenerator (standardForm k n) i) = + freeWeylLinearCombination M (freeWeylGenerator (standardForm k n)) i := + freeWeylSymplecticAlgHom_generator M (standardForm k n) + (standardSymplecticHpres k M hM) i + +theorem standardSymplecticAlgHom_comp_eq_id {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hNM : N * M = 1) : + (standardSymplecticAlgHom k M hM).comp + (standardSymplecticAlgHom k N hN) = + AlgHom.id k (FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n)) := by + apply RingQuot.ringQuot_ext' k + apply FreeAlgebra.hom_ext + funext i + change standardSymplecticAlgHom k M hM + (standardSymplecticAlgHom k N hN + (freeWeylGenerator (standardForm k n) i)) = + freeWeylGenerator (standardForm k n) i + calc + _ = freeWeylLinearCombination (N * M) + (freeWeylGenerator (standardForm k n)) i := by + simpa [standardSymplecticAlgHom] using + freeWeylSymplecticAlgHom_comp_generator M N (standardForm k n) + (standardSymplecticHpres k M hM) + (standardSymplecticHpres k N hN) i + _ = _ := by + rw [hNM] + exact freeWeylLinearCombination_one (standardForm k n) i + +/-- A general-rank symplectic change with an explicitly certified inverse. -/ +def standardSymplecticAlgEquivOfInverse {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hMN : M * N = 1) (hNM : N * M = 1) : + FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n) ≃ₐ[k] + FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n) := + AlgEquiv.mk + { toFun := standardSymplecticAlgHom k M hM + invFun := standardSymplecticAlgHom k N hN + left_inv := fun x => DFunLike.congr_fun + (standardSymplecticAlgHom_comp_eq_id k N M hN hM hMN) x + right_inv := fun x => DFunLike.congr_fun + (standardSymplecticAlgHom_comp_eq_id k M N hM hN hNM) x } + (standardSymplecticAlgHom k M hM).map_mul + (standardSymplecticAlgHom k M hM).map_add + (standardSymplecticAlgHom k M hM).commutes + +@[simp] theorem standardSymplecticAlgEquivOfInverse_generator {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hMN : M * N = 1) (hNM : N * M = 1) (i : Fin n ⊕ Fin n) : + standardSymplecticAlgEquivOfInverse k M N hM hN hMN hNM + (freeWeylGenerator (standardForm k n) i) = + freeWeylLinearCombination M (freeWeylGenerator (standardForm k n)) i := + standardSymplecticAlgHom_generator k M hM i + +@[simp] theorem standardSymplecticAlgEquivOfInverse_symm_generator {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hMN : M * N = 1) (hNM : N * M = 1) (i : Fin n ⊕ Fin n) : + (standardSymplecticAlgEquivOfInverse k M N hM hN hMN hNM).symm + (freeWeylGenerator (standardForm k n) i) = + freeWeylLinearCombination N (freeWeylGenerator (standardForm k n)) i := + standardSymplecticAlgHom_generator k N hN i + +/- Exact statement pins for composition order and both substitution maps. -/ +example {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hNM : N * M = 1) : + (standardSymplecticAlgHom k M hM).comp + (standardSymplecticAlgHom k N hN) = + AlgHom.id k (FreeWeyl k (Fin n ⊕ Fin n) (standardForm k n)) := + standardSymplecticAlgHom_comp_eq_id k M N hM hN hNM + +example {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hMN : M * N = 1) (hNM : N * M = 1) (i : Fin n ⊕ Fin n) : + standardSymplecticAlgEquivOfInverse k M N hM hN hMN hNM + (freeWeylGenerator (standardForm k n) i) = + freeWeylLinearCombination M (freeWeylGenerator (standardForm k n)) i := + standardSymplecticAlgEquivOfInverse_generator k M N hM hN hMN hNM i + +example {n : ℕ} + (M N : Matrix (Fin n ⊕ Fin n) (Fin n ⊕ Fin n) k) + (hM : M * standardForm k n * Matrix.transpose M = standardForm k n) + (hN : N * standardForm k n * Matrix.transpose N = standardForm k n) + (hMN : M * N = 1) (hNM : N * M = 1) (i : Fin n ⊕ Fin n) : + (standardSymplecticAlgEquivOfInverse k M N hM hN hMN hNM).symm + (freeWeylGenerator (standardForm k n) i) = + freeWeylLinearCombination N (freeWeylGenerator (standardForm k n)) i := + standardSymplecticAlgEquivOfInverse_symm_generator + k M N hM hN hMN hNM i + + +end + +end Stafford38.WeylSymplectic diff --git a/LeanPool/Stafford38/Stafford38/Weyl/Transposition.lean b/LeanPool/Stafford38/Stafford38/Weyl/Transposition.lean new file mode 100644 index 0000000000..44c8ebef4c --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/Transposition.lean @@ -0,0 +1,258 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib.Algebra.Algebra.Opposite +import Mathlib.Algebra.Module.RingHom +import LeanPool.Stafford38.Stafford38.Weyl.IteratedEquivalence + +/-! +# Transposition of the presented Weyl algebra + +This file constructs the scalar-preserving Weyl transposition as an algebra +equivalence with the opposite algebra. Coordinates are fixed and momenta +change sign. The construction uses only the checked universal property of +the quotient presentation. +-/ + +namespace Stafford38.WeylTransposition + +open MulOpposite +open Stafford +open AlgebraicAnalysis +open Stafford38.WeylUniversal +open Stafford38.WeylIteratedEquivalence + +noncomputable section + +universe u v + +variable (k : Type u) [Field k] + +/-- The coordinate generator with index `i`. -/ +def coordinate (n : Nat) (i : Fin n) : PresentedWeyl k n := + freeWeylGenerator (Matrix.J (Fin n) k) (.inl i) + +/-- The momentum generator with index `i`. -/ +def momentum (n : Nat) (i : Fin n) : PresentedWeyl k n := + freeWeylGenerator (Matrix.J (Fin n) k) (.inr i) + +/-- Generator images for the Weyl transposition. -/ +def transposedGenerator (n : Nat) : + (Fin n ⊕ Fin n) → (PresentedWeyl k n)ᵐᵒᵖ + | .inl i => op (coordinate k n i) + | .inr i => op (-momentum k n i) + +private theorem neg_commutator_right_neg {A : Type*} [Ring A] (a b : A) : + -Stafford.commutator a (-b) = Stafford.commutator a b := by + simp [Stafford.commutator] + abel + +private theorem neg_commutator_left_neg {A : Type*} [Ring A] (a b : A) : + -Stafford.commutator (-a) b = Stafford.commutator a b := by + simp [Stafford.commutator] + abel + +private theorem neg_commutator_both_neg {A : Type*} [Ring A] (a b : A) : + -Stafford.commutator (-a) (-b) = -Stafford.commutator a b := by + simp [Stafford.commutator] + +theorem underlying_transposedGenerator_commutator (n : Nat) : + ∀ i j, + -Stafford.commutator (unop (transposedGenerator k n i)) + (unop (transposedGenerator k n j)) = + algebraMap k (PresentedWeyl k n) (Matrix.J (Fin n) k i j) := by + intro i j + cases i with + | inl i => + cases j with + | inl j => + change -Stafford.commutator (coordinate k n i) (coordinate k n j) = _ + rw [show Stafford.commutator (coordinate k n i) (coordinate k n j) = + algebraMap k (PresentedWeyl k n) + (Matrix.J (Fin n) k (.inl i) (.inl j)) from + freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin n) k) (.inl i) (.inl j)] + simp [Matrix.J] + | inr j => + change -Stafford.commutator (coordinate k n i) (-momentum k n j) = _ + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin n) k) (.inl i) (.inr j) + rw [neg_commutator_right_neg] + exact h + | inr i => + cases j with + | inl j => + change -Stafford.commutator (-momentum k n i) (coordinate k n j) = _ + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin n) k) (.inr i) (.inl j) + rw [neg_commutator_left_neg] + exact h + | inr j => + change -Stafford.commutator (-momentum k n i) (-momentum k n j) = _ + have h := freeWeylGenerator_commutator + (k := k) (Matrix.J (Fin n) k) (.inr i) (.inr j) + have hJ : Matrix.J (Fin n) k (.inr i) (.inr j) = 0 := by + simp [Matrix.J] + rw [hJ] at h ⊢ + rw [neg_commutator_both_neg] + change + -Stafford.commutator + (freeWeylGenerator (Matrix.J (Fin n) k) (.inr i)) + (freeWeylGenerator (Matrix.J (Fin n) k) (.inr j)) = _ + rw [h, map_zero, neg_zero] + +theorem transposedGenerator_commutator (n : Nat) : + ∀ i j, + Stafford.commutator (transposedGenerator k n i) (transposedGenerator k n j) = + algebraMap k (PresentedWeyl k n)ᵐᵒᵖ (Matrix.J (Fin n) k i j) := by + intro i j + apply unop_injective + simpa [Stafford.commutator] using + underlying_transposedGenerator_commutator k n i j + +/-- The scalar-preserving anti-homomorphism `x_i ↦ x_i`, `p_i ↦ -p_i`, +represented as an algebra homomorphism to the opposite algebra. -/ +def transpositionHom (n : Nat) : + PresentedWeyl k n →ₐ[k] (PresentedWeyl k n)ᵐᵒᵖ := + freeWeylLift (Matrix.J (Fin n) k) (transposedGenerator k n) + (transposedGenerator_commutator k n) + +@[simp] theorem transpositionHom_coordinate (n : Nat) (i : Fin n) : + transpositionHom k n (coordinate k n i) = op (coordinate k n i) := by + simpa [transpositionHom, transposedGenerator, coordinate] using + freeWeylLift_generator (k := k) (Matrix.J (Fin n) k) + (transposedGenerator k n) (transposedGenerator_commutator k n) (.inl i) + +@[simp] theorem transpositionHom_momentum (n : Nat) (i : Fin n) : + transpositionHom k n (momentum k n i) = op (-momentum k n i) := by + simpa [transpositionHom, transposedGenerator, momentum] using + freeWeylLift_generator (k := k) (Matrix.J (Fin n) k) + (transposedGenerator k n) (transposedGenerator_commutator k n) (.inr i) + +/-- Applying transposition once on each side of the opposite equivalence is +the identity. -/ +theorem opComm_transpositionHom_comp_transpositionHom (n : Nat) : + (AlgHom.opComm (transpositionHom k n)).comp (transpositionHom k n) = + AlgHom.id k (PresentedWeyl k n) := by + apply freeWeyl_algHom_ext + intro i + cases i with + | inl i => + simp only [AlgHom.comp_apply, AlgHom.id_apply] + rw [show freeWeylGenerator (Matrix.J (Fin n) k) (.inl i) = + coordinate k n i from rfl, transpositionHom_coordinate] + change unop (transpositionHom k n (coordinate k n i)) = coordinate k n i + rw [transpositionHom_coordinate] + exact unop_op _ + | inr i => + simp only [AlgHom.comp_apply, AlgHom.id_apply] + rw [show freeWeylGenerator (Matrix.J (Fin n) k) (.inr i) = + momentum k n i from rfl, transpositionHom_momentum] + change unop (transpositionHom k n (-momentum k n i)) = momentum k n i + rw [map_neg, transpositionHom_momentum] + simp + +theorem transpositionHom_comp_opComm_transpositionHom (n : Nat) : + (transpositionHom k n).comp (AlgHom.opComm (transpositionHom k n)) = + AlgHom.id k (PresentedWeyl k n)ᵐᵒᵖ := by + apply AlgHom.ext + intro a + rcases a with ⟨a⟩ + apply unop_injective + have h := congrArg (fun f : PresentedWeyl k n →ₐ[k] PresentedWeyl k n => f a) + (opComm_transpositionHom_comp_transpositionHom k n) + exact h + +/-- Transposition is a scalar-preserving equivalence with the opposite Weyl +algebra. -/ +def transpositionEquiv (n : Nat) : + PresentedWeyl k n ≃ₐ[k] (PresentedWeyl k n)ᵐᵒᵖ := + AlgEquiv.ofAlgHom (transpositionHom k n) (AlgHom.opComm (transpositionHom k n)) + (transpositionHom_comp_opComm_transpositionHom k n) + (opComm_transpositionHom_comp_transpositionHom k n) + +@[simp] theorem transpositionEquiv_apply (n : Nat) (a : PresentedWeyl k n) : + transpositionEquiv k n a = transpositionHom k n a := rfl + +@[simp] theorem transpositionEquiv_coordinate (n : Nat) (i : Fin n) : + transpositionEquiv k n (coordinate k n i) = op (coordinate k n i) := by + simp [transpositionEquiv] + +@[simp] theorem transpositionEquiv_momentum (n : Nat) (i : Fin n) : + transpositionEquiv k n (momentum k n i) = op (-momentum k n i) := by + simp [transpositionEquiv] + +theorem transpositionEquiv_injective (n : Nat) : + Function.Injective (transpositionEquiv k n) := + (transpositionEquiv k n).injective + +theorem transpositionEquiv_surjective (n : Nat) : + Function.Surjective (transpositionEquiv k n) := + (transpositionEquiv k n).surjective + +/-- The usual unbundled anti-automorphism underlying `transpositionEquiv`. -/ +def transpose (n : Nat) (a : PresentedWeyl k n) : PresentedWeyl k n := + unop (transpositionEquiv k n a) + +@[simp] theorem transpose_coordinate (n : Nat) (i : Fin n) : + transpose k n (coordinate k n i) = coordinate k n i := by + simp [transpose] + +@[simp] theorem transpose_momentum (n : Nat) (i : Fin n) : + transpose k n (momentum k n i) = -momentum k n i := by + simp [transpose] + +@[simp] theorem transpose_algebraMap (n : Nat) (c : k) : + transpose k n (algebraMap k (PresentedWeyl k n) c) = + algebraMap k (PresentedWeyl k n) c := by + simp [transpose] + +theorem transpose_mul (n : Nat) (a b : PresentedWeyl k n) : + transpose k n (a * b) = transpose k n b * transpose k n a := by + simp [transpose] + +@[simp] theorem transpose_transpose (n : Nat) (a : PresentedWeyl k n) : + transpose k n (transpose k n a) = a := by + have h := congrArg (fun f : PresentedWeyl k n →ₐ[k] PresentedWeyl k n => f a) + (opComm_transpositionHom_comp_transpositionHom k n) + exact h + +theorem transpose_injective (n : Nat) : Function.Injective (transpose k n) := by + intro a b h + simpa only [transpose_transpose] using congrArg (transpose k n) h + +/-- A right `PresentedWeyl`-module becomes a left module by restriction of +scalars along transposition. -/ +def transposedLeftModule (n : Nat) (M : Type v) [AddCommMonoid M] + [Module (PresentedWeyl k n)ᵐᵒᵖ M] : Module (PresentedWeyl k n) M := + Module.compHom M (transpositionEquiv k n).toRingEquiv.toRingHom + +theorem transposedLeftModule_smul (n : Nat) (M : Type v) [AddCommMonoid M] + [Module (PresentedWeyl k n)ᵐᵒᵖ M] + (a : PresentedWeyl k n) (m : M) : + @SMul.smul (PresentedWeyl k n) M + (transposedLeftModule k n M).toSMul a m = + transpositionEquiv k n a • m := rfl + +theorem transposedLeftModule_coordinate_smul (n : Nat) (M : Type v) + [AddCommMonoid M] [Module (PresentedWeyl k n)ᵐᵒᵖ M] + (i : Fin n) (m : M) : + @SMul.smul (PresentedWeyl k n) M + (transposedLeftModule k n M).toSMul (coordinate k n i) m = + op (coordinate k n i) • m := by + rw [transposedLeftModule_smul, transpositionEquiv_coordinate] + +theorem transposedLeftModule_momentum_smul (n : Nat) (M : Type v) + [AddCommMonoid M] [Module (PresentedWeyl k n)ᵐᵒᵖ M] + (i : Fin n) (m : M) : + @SMul.smul (PresentedWeyl k n) M + (transposedLeftModule k n M).toSMul (momentum k n i) m = + op (-momentum k n i) • m := by + rw [transposedLeftModule_smul, transpositionEquiv_momentum] + + +end +end Stafford38.WeylTransposition diff --git a/LeanPool/Stafford38/Stafford38/Weyl/TranspositionFiltration.lean b/LeanPool/Stafford38/Stafford38/Weyl/TranspositionFiltration.lean new file mode 100644 index 0000000000..1c0b375202 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/TranspositionFiltration.lean @@ -0,0 +1,772 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.Stafford38.Weyl.Transposition +import LeanPool.Stafford38.Stafford38.Weyl.GradedAlgebra +import LeanPool.Stafford38.Stafford38.Weyl.SymbolCompatibility + +/-! +# Filtration and symbol transport under Weyl transposition + +The Weyl transposition reverses products, fixes coordinates, and negates +momenta. This file proves directly from the checked PBW filtration that it +preserves both differential order and Bernstein degree. No filtered +`D`-module or characteristic-variety theorem is used here. +-/ + +namespace Stafford38.WeylTranspositionFiltration + +open MulOpposite +open Stafford +open Stafford38.Characteristic +open Stafford38.CharacteristicLinearAction +open Stafford38.WeylAssociatedGraded +open Stafford38.WeylFiltration +open Stafford38.WeylIteratedEquivalence +open Stafford38.WeylLeadingSymbol +open Stafford38.WeylPBW +open Stafford38.WeylTransposition + +noncomputable section + + +universe u + +variable (k : Type u) [Field k] + +@[simp] theorem transpose_zero (n : Nat) : + transpose k n 0 = 0 := by + simp [transpose] + +@[simp] theorem transpose_add (n : Nat) (a b : PresentedWeyl k n) : + transpose k n (a + b) = transpose k n a + transpose k n b := by + simp [transpose] + +@[simp] theorem transpose_smul (n : Nat) (c : k) (a : PresentedWeyl k n) : + transpose k n (c • a) = c • transpose k n a := by + simp [transpose] + +@[simp] theorem transpose_pow (n : Nat) (a : PresentedWeyl k n) (r : Nat) : + transpose k n (a ^ r) = transpose k n a ^ r := by + induction r with + | zero => simp [transpose] + | succ r ih => + rw [pow_succ, transpose_mul, ih] + calc + transpose k n a * transpose k n a ^ r = + transpose k n a ^ r * transpose k n a := + ((Commute.refl (transpose k n a)).pow_right r).eq + _ = transpose k n a ^ (r + 1) := (pow_succ _ _).symm + +theorem transpose_previousWeylEmbedding (n : Nat) (a : PresentedWeyl k n) : + transpose k (n + 1) (previousWeylEmbedding k n a) = + previousWeylEmbedding k n (transpose k n a) := by + let lhs : PresentedWeyl k n →ₐ[k] (PresentedWeyl k (n + 1))ᵐᵒᵖ := + (transpositionHom k (n + 1)).comp (previousWeylEmbedding k n) + let rhs : PresentedWeyl k n →ₐ[k] (PresentedWeyl k (n + 1))ᵐᵒᵖ := + (AlgHom.op (previousWeylEmbedding k n)).comp (transpositionHom k n) + have h : lhs = rhs := by + apply Stafford38.WeylUniversal.freeWeyl_algHom_ext + intro i + dsimp [lhs, rhs] + cases i with + | inl i => + rw [previousWeylEmbedding_generator, + show freeWeylGenerator (Matrix.J (Fin n) k) (.inl i) = + coordinate k n i from rfl, + transpositionHom_coordinate] + change transpositionHom k (n + 1) (oldGenerator k n (.inl i)) = + op (previousWeylEmbedding k n (coordinate k n i)) + rw [show oldGenerator k n (.inl i) = coordinate k (n + 1) i.succ from rfl, + transpositionHom_coordinate] + have hp := previousWeylEmbedding_generator k n (.inl i) + change previousWeylEmbedding k n (coordinate k n i) = + coordinate k (n + 1) i.succ at hp + exact congrArg op hp.symm + | inr i => + rw [previousWeylEmbedding_generator, + show freeWeylGenerator (Matrix.J (Fin n) k) (.inr i) = + momentum k n i from rfl, + transpositionHom_momentum] + change transpositionHom k (n + 1) (oldGenerator k n (.inr i)) = + op (previousWeylEmbedding k n (-momentum k n i)) + rw [show oldGenerator k n (.inr i) = momentum k (n + 1) i.succ from rfl, + transpositionHom_momentum, map_neg] + have hp := previousWeylEmbedding_generator k n (.inr i) + change previousWeylEmbedding k n (momentum k n i) = + momentum k (n + 1) i.succ at hp + exact congrArg op (congrArg Neg.neg hp.symm) + have ha := DFunLike.congr_fun h a + exact congrArg MulOpposite.unop ha + +theorem coordinate_mem_bernsteinPiece {n : Nat} (i : Fin n) : + coordinate k n i ∈ bernsteinPiece k n 1 := by + rw [bernsteinPiece, mem_presentedWeightPiece, coordinate, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X', ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight, bernsteinWeight] at hweight) + +theorem momentum_mem_bernsteinPiece {n : Nat} (i : Fin n) : + momentum k n i ∈ bernsteinPiece k n 1 := by + rw [bernsteinPiece, mem_presentedWeightPiece, momentum, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X', ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight, bernsteinWeight] at hweight) + +theorem coordinate_mem_orderPiece {n : Nat} (i : Fin n) : + coordinate k n i ∈ orderPiece k n 0 := by + rw [orderPiece, mem_presentedWeightPiece, coordinate, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X', ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight, orderWeight, fibreWeight] at hweight) + +theorem momentum_mem_orderPiece {n : Nat} (i : Fin n) : + momentum k n i ∈ orderPiece k n 1 := by + rw [orderPiece, mem_presentedWeightPiece, momentum, + presentedNormalFormLinearEquiv_generator] + intro m hm + simp only [MvPolynomial.coeff_X', ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight, orderWeight, fibreWeight] at hweight) + +private theorem one_mem_weightPiece {n : Nat} (w : PhaseVar n → Nat) : + (1 : PresentedWeyl k n) ∈ presentedWeightPiece k w 0 := by + rw [mem_presentedWeightPiece, presentedNormalFormLinearEquiv_one] + intro m hm + simp only [MvPolynomial.coeff_one, ne_eq, ite_eq_right_iff] at hm + by_contra hweight + exact hm (by + intro h + subst m + simp [monomialWeight] at hweight) + +theorem coordinate_pow_mem_bernsteinPiece {n : Nat} (i : Fin n) (r : Nat) : + coordinate k n i ^ r ∈ bernsteinPiece k n r := by + induction r with + | zero => simpa [bernsteinPiece] using one_mem_weightPiece k (@bernsteinWeight n) + | succ r ih => + simpa [pow_succ] using mul_mem_bernsteinPiece k ih + (coordinate_mem_bernsteinPiece k i) + +theorem momentum_pow_mem_bernsteinPiece {n : Nat} (i : Fin n) (r : Nat) : + (-momentum k n i) ^ r ∈ bernsteinPiece k n r := by + have hm : -momentum k n i ∈ bernsteinPiece k n 1 := + (bernsteinPiece k n 1).neg_mem (momentum_mem_bernsteinPiece k i) + induction r with + | zero => simpa [bernsteinPiece] using one_mem_weightPiece k (@bernsteinWeight n) + | succ r ih => simpa [pow_succ] using mul_mem_bernsteinPiece k ih hm + +theorem coordinate_pow_mem_orderPiece {n : Nat} (i : Fin n) (r : Nat) : + coordinate k n i ^ r ∈ orderPiece k n 0 := by + induction r with + | zero => simpa [orderPiece] using one_mem_weightPiece k (@orderWeight n) + | succ r ih => + simpa [pow_succ] using mul_mem_orderPiece k ih + (coordinate_mem_orderPiece k i) + +theorem momentum_pow_mem_orderPiece {n : Nat} (i : Fin n) (r : Nat) : + (-momentum k n i) ^ r ∈ orderPiece k n r := by + have hm : -momentum k n i ∈ orderPiece k n 1 := + (orderPiece k n 1).neg_mem (momentum_mem_orderPiece k i) + induction r with + | zero => simpa [orderPiece] using one_mem_weightPiece k (@orderWeight n) + | succ r ih => simpa [pow_succ] using mul_mem_orderPiece k ih hm + +theorem previousWeylEmbedding_mem_bernsteinPiece {n N : Nat} + {a : PresentedWeyl k n} (ha : a ∈ bernsteinPiece k n N) : + previousWeylEmbedding k n a ∈ bernsteinPiece k (n + 1) N := by + simpa [presentedCoefficientOrdered] using + presentedCoefficientOrdered_mem_bernsteinPiece k n N 0 0 a ha + +theorem previousWeylEmbedding_mem_orderPiece {n N : Nat} + {a : PresentedWeyl k n} (ha : a ∈ orderPiece k n N) : + previousWeylEmbedding k n a ∈ orderPiece k (n + 1) N := by + simpa [presentedCoefficientOrdered] using + presentedCoefficientOrdered_mem_orderPiece k n N 0 0 a ha + +theorem transpose_orderedMonomial_mem_bernsteinPiece : + ∀ (n : Nat) (a p : Fin n → Nat), + transpose k n (presentedOrderedMonomial k n a p) ∈ + bernsteinPiece k n + (monomialWeight (@bernsteinWeight n) (phaseExponent a p)) := by + intro n + induction n with + | zero => + intro a p + have he : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [he] + simpa [presentedOrderedMonomial, monomialWeight, bernsteinPiece, + transpose] using one_mem_weightPiece k (@bernsteinWeight 0) + | succ n ih => + intro a p + let oldA : Fin n → Nat := fun i => a i.succ + let oldP : Fin n → Nat := fun i => p i.succ + have hold := previousWeylEmbedding_mem_bernsteinPiece k + (ih oldA oldP) + have hx := coordinate_pow_mem_bernsteinPiece k + (0 : Fin (n + 1)) (a 0) + have hp := momentum_pow_mem_bernsteinPiece k + (0 : Fin (n + 1)) (p 0) + have hmul := mul_mem_bernsteinPiece k + (mul_mem_bernsteinPiece k hp hx) hold + rw [presentedOrderedMonomial, transpose_mul, transpose_mul, + transpose_pow, transpose_pow, + show presentedMomentum k n = momentum k (n + 1) 0 from rfl, + show presentedCoordinate k n = coordinate k (n + 1) 0 from rfl, + transpose_momentum, transpose_coordinate, + transpose_previousWeylEmbedding] + rw [monomialWeight_phaseExponent_succ_bernstein] + simpa [oldA, oldP, mul_assoc, add_assoc, add_comm, add_left_comm] using hmul + +theorem transpose_orderedMonomial_mem_orderPiece : + ∀ (n : Nat) (a p : Fin n → Nat), + transpose k n (presentedOrderedMonomial k n a p) ∈ + orderPiece k n + (monomialWeight (@orderWeight n) (phaseExponent a p)) := by + intro n + induction n with + | zero => + intro a p + have he : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [he] + simpa [presentedOrderedMonomial, monomialWeight, orderPiece, + transpose] using one_mem_weightPiece k (@orderWeight 0) + | succ n ih => + intro a p + let oldA : Fin n → Nat := fun i => a i.succ + let oldP : Fin n → Nat := fun i => p i.succ + have hold := previousWeylEmbedding_mem_orderPiece k (ih oldA oldP) + have hx := coordinate_pow_mem_orderPiece k + (0 : Fin (n + 1)) (a 0) + have hp := momentum_pow_mem_orderPiece k + (0 : Fin (n + 1)) (p 0) + have hmul := mul_mem_orderPiece k (mul_mem_orderPiece k hp hx) hold + rw [presentedOrderedMonomial, transpose_mul, transpose_mul, + transpose_pow, transpose_pow, + show presentedMomentum k n = momentum k (n + 1) 0 from rfl, + show presentedCoordinate k n = coordinate k (n + 1) 0 from rfl, + transpose_momentum, transpose_coordinate, + transpose_previousWeylEmbedding] + rw [monomialWeight_phaseExponent_succ_order] + simpa [oldA, oldP, mul_assoc, add_assoc, add_comm, add_left_comm] using hmul + +theorem transpose_mem_bernsteinPiece {n N : Nat} {a : PresentedWeyl k n} + (ha : a ∈ bernsteinPiece k n N) : + transpose k n a ∈ bernsteinPiece k n N := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at ha + change transpose k n a ∈ presentedWeightPiece k bernsteinWeight N + induction ha using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + rw [presentedPBWBasis_apply] + have hmono := transpose_orderedMonomial_mem_bernsteinPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + exact presentedWeightPiece_mono k bernsteinWeight hm + (by simpa [bernsteinPiece, phaseExponent_split] using hmono) + | zero => + rw [transpose_zero] + exact (presentedWeightPiece k bernsteinWeight N).zero_mem + | add x y hx hy ihx ihy => + rw [transpose_add] + exact (presentedWeightPiece k bernsteinWeight N).add_mem ihx ihy + | smul c x hx ih => + rw [transpose_smul] + exact (presentedWeightPiece k bernsteinWeight N).smul_mem c ih + +theorem transpose_mem_orderPiece {n N : Nat} {a : PresentedWeyl k n} + (ha : a ∈ orderPiece k n N) : + transpose k n a ∈ orderPiece k n N := by + rw [orderPiece, presentedWeightPiece_eq_span] at ha + change transpose k n a ∈ presentedWeightPiece k orderWeight N + induction ha using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + rw [presentedPBWBasis_apply] + have hmono := transpose_orderedMonomial_mem_orderPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + exact presentedWeightPiece_mono k orderWeight hm + (by simpa [orderPiece, phaseExponent_split] using hmono) + | zero => + rw [transpose_zero] + exact (presentedWeightPiece k orderWeight N).zero_mem + | add x y hx hy ihx ihy => + rw [transpose_add] + exact (presentedWeightPiece k orderWeight N).add_mem ihx ihy + | smul c x hx ih => + rw [transpose_smul] + exact (presentedWeightPiece k orderWeight N).smul_mem c ih + +theorem transpose_mem_bernsteinPiece_iff {n N : Nat} (a : PresentedWeyl k n) : + transpose k n a ∈ bernsteinPiece k n N ↔ a ∈ bernsteinPiece k n N := by + constructor + · intro h + simpa using transpose_mem_bernsteinPiece k h + · exact transpose_mem_bernsteinPiece k + +theorem transpose_mem_orderPiece_iff {n N : Nat} (a : PresentedWeyl k n) : + transpose k n a ∈ orderPiece k n N ↔ a ∈ orderPiece k n N := by + constructor + · intro h + simpa using transpose_mem_orderPiece k h + · exact transpose_mem_orderPiece k + +/-- The expected phase-space sign substitution: coordinates are fixed and +momentum variables are negated. -/ +def symbolTransposition {n : Nat} : SymbolRing k n →ₐ[k] SymbolRing k n := + MvPolynomial.aeval (Sum.elim + (fun i : Fin n => MvPolynomial.X (.inl i)) + (fun i : Fin n => -MvPolynomial.X (.inr i))) + +@[simp] theorem symbolTransposition_coordinate {n : Nat} (i : Fin n) : + symbolTransposition k (MvPolynomial.X (.inl i)) = MvPolynomial.X (.inl i) := by + simp [symbolTransposition] + +@[simp] theorem symbolTransposition_momentum {n : Nat} (i : Fin n) : + symbolTransposition k (MvPolynomial.X (.inr i)) = -MvPolynomial.X (.inr i) := by + simp [symbolTransposition] + +private theorem principal_coordinate_bernstein {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@bernsteinWeight n) 1 (coordinate k n i) = + MvPolynomial.X (.inl i) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, coordinate, + presentedNormalFormLinearEquiv_generator] + have hx : MvPolynomial.X (.inl i : PhaseVar n) = + MvPolynomial.monomial + (Finsupp.single (.inl i : PhaseVar n) 1) (1 : k) := by + simpa using (MvPolynomial.X_pow_eq_monomial + (R := k) (n := (.inl i : PhaseVar n)) (e := 1)) + rw [hx] + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, bernsteinWeight] + +private theorem principal_momentum_bernstein {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@bernsteinWeight n) 1 (momentum k n i) = + MvPolynomial.X (.inr i) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, momentum, + presentedNormalFormLinearEquiv_generator] + have hx : MvPolynomial.X (.inr i : PhaseVar n) = + MvPolynomial.monomial + (Finsupp.single (.inr i : PhaseVar n) 1) (1 : k) := by + simpa using (MvPolynomial.X_pow_eq_monomial + (R := k) (n := (.inr i : PhaseVar n)) (e := 1)) + rw [hx] + rw [weightedHomogeneousComponent_monomial] + simp [monomialWeight, bernsteinWeight] + +private theorem principal_negMomentum_pow_bernstein {n : Nat} + (i : Fin n) (r : Nat) : + presentedPrincipalComponent k (@bernsteinWeight n) r + ((-momentum k n i) ^ r) = (-MvPolynomial.X (.inr i)) ^ r := by + have hm : -momentum k n i ∈ bernsteinPiece k n 1 := + (bernsteinPiece k n 1).neg_mem (momentum_mem_bernsteinPiece k i) + rw [Stafford38.WeylSymbolCompatibility.pow_principal_bernstein k hm, + map_neg, principal_momentum_bernstein] + +private theorem principal_coordinate_pow_bernstein {n : Nat} + (i : Fin n) (r : Nat) : + presentedPrincipalComponent k (@bernsteinWeight n) r + (coordinate k n i ^ r) = MvPolynomial.X (.inl i) ^ r := by + rw [Stafford38.WeylSymbolCompatibility.pow_principal_bernstein k + (coordinate_mem_bernsteinPiece k i), + principal_coordinate_bernstein] + +private theorem principal_previous_bernstein {n N : Nat} + (a : PresentedWeyl k n) : + presentedPrincipalComponent k (@bernsteinWeight (n + 1)) N + (previousWeylEmbedding k n a) = + MvPolynomial.rename oldIndex + (presentedPrincipalComponent k (@bernsteinWeight n) N a) := by + simpa [presentedCoefficientOrdered, extendPhaseExponent] using + presentedPrincipalComponent_coefficientOrdered_bernstein k n N 0 0 a + +theorem symbolTransposition_rename_oldIndex {n : Nat} (f : SymbolRing k n) : + symbolTransposition k (MvPolynomial.rename oldIndex f) = + MvPolynomial.rename oldIndex (symbolTransposition k f) := by + let lhs : SymbolRing k n →ₐ[k] SymbolRing k (n + 1) := + (symbolTransposition k).comp (MvPolynomial.rename oldIndex) + let rhs : SymbolRing k n →ₐ[k] SymbolRing k (n + 1) := + (MvPolynomial.rename oldIndex).comp (symbolTransposition k) + have h : lhs = rhs := by + apply MvPolynomial.algHom_ext + intro i + cases i with + | inl i => simp [lhs, rhs, oldIndex] + | inr i => simp [lhs, rhs, oldIndex] + exact DFunLike.congr_fun h f + +theorem principal_transpose_orderedMonomial_bernstein : + ∀ (n : Nat) (a p : Fin n → Nat), + presentedPrincipalComponent k (@bernsteinWeight n) + (monomialWeight (@bernsteinWeight n) (phaseExponent a p)) + (transpose k n (presentedOrderedMonomial k n a p)) = + symbolTransposition k + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) := by + intro n + induction n with + | zero => + intro a p + have he : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [he] + simp [presentedOrderedMonomial, transpose, monomialWeight, + presentedPrincipalComponent, presentedNormalFormLinearEquiv_one, + weightedHomogeneousComponent_monomial, symbolTransposition] + | succ n ih => + intro a p + let oldA : Fin n → Nat := fun i => a i.succ + let oldP : Fin n → Nat := fun i => p i.succ + let oldD := monomialWeight (@bernsteinWeight n) (phaseExponent oldA oldP) + have hold := previousWeylEmbedding_mem_bernsteinPiece k + (transpose_orderedMonomial_mem_bernsteinPiece k n oldA oldP) + have hx := coordinate_pow_mem_bernsteinPiece k + (0 : Fin (n + 1)) (a 0) + have hp := momentum_pow_mem_bernsteinPiece k + (0 : Fin (n + 1)) (p 0) + have hxo := mul_mem_bernsteinPiece k hx hold + rw [presentedOrderedMonomial, transpose_mul, transpose_mul, + transpose_pow, transpose_pow, + show presentedMomentum k n = momentum k (n + 1) 0 from rfl, + show presentedCoordinate k n = coordinate k (n + 1) 0 from rfl, + transpose_momentum, transpose_coordinate, + transpose_previousWeylEmbedding, + monomialWeight_phaseExponent_succ_bernstein] + change presentedPrincipalComponent k (@bernsteinWeight (n + 1)) + (oldD + a 0 + p 0) + ((-momentum k (n + 1) 0) ^ p 0 * + (coordinate k (n + 1) 0 ^ a 0 * + previousWeylEmbedding k n + (transpose k n (presentedOrderedMonomial k n oldA oldP)))) = _ + rw [show oldD + a 0 + p 0 = p 0 + (a 0 + oldD) by omega, + presentedPrincipalComponent_mul_bernstein k hp hxo, + presentedPrincipalComponent_mul_bernstein k hx hold, + principal_negMomentum_pow_bernstein, + principal_coordinate_pow_bernstein, + principal_previous_bernstein, ih oldA oldP] + rw [Stafford38.WeylSymbolCompatibility.phaseMonomial_succ_decompose] + simp only [map_mul, map_pow, symbolTransposition_coordinate, + symbolTransposition_momentum, symbolTransposition_rename_oldIndex] + ring + +theorem principal_transpose_bernstein {n N : Nat} {a : PresentedWeyl k n} + (ha : a ∈ bernsteinPiece k n N) : + presentedPrincipalComponent k (@bernsteinWeight n) N (transpose k n a) = + symbolTransposition k + (presentedPrincipalComponent k (@bernsteinWeight n) N a) := by + rw [bernsteinPiece, presentedWeightPiece_eq_span] at ha + induction ha using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + let d := monomialWeight (@bernsteinWeight n) m + by_cases hd : d = N + · subst N + rw [presentedPBWBasis_apply] + have ht := principal_transpose_orderedMonomial_bernstein k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + have ht' : + presentedPrincipalComponent k (@bernsteinWeight n) d + (transpose k n + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i)))) = + symbolTransposition k (MvPolynomial.monomial m (1 : k)) := by + simpa [phaseExponent_split] using ht + have ho : + presentedPrincipalComponent k (@bernsteinWeight n) d + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) = + MvPolynomial.monomial m (1 : k) := by + rw [← presentedPBWBasis_apply, + presentedPrincipalComponent_basis, if_pos rfl] + rw [ht', ho] + · have hdlt : d < N := lt_of_le_of_ne hm hd + have ht := transpose_orderedMonomial_mem_bernsteinPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + rw [presentedPBWBasis_apply] + have ht' : transpose k n + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) ∈ + bernsteinPiece k n d := by + simpa [phaseExponent_split] using ht + have ho : + presentedPrincipalComponent k (@bernsteinWeight n) N + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) = 0 := by + rw [← presentedPBWBasis_apply, + presentedPrincipalComponent_basis, if_neg hd] + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + bernsteinWeight _ ht' hdlt, ho, map_zero] + | zero => simp + | add x y hx hy ihx ihy => simp only [transpose_add, map_add, ihx, ihy] + | smul c x hx ih => simp only [transpose_smul, map_smul, ih] + +private theorem principal_coordinate_order {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@orderWeight n) 0 (coordinate k n i) = + MvPolynomial.X (.inl i) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, coordinate, + presentedNormalFormLinearEquiv_generator] + have hx : MvPolynomial.X (.inl i : PhaseVar n) = + MvPolynomial.monomial + (Finsupp.single (.inl i : PhaseVar n) 1) (1 : k) := by + simpa using (MvPolynomial.X_pow_eq_monomial + (R := k) (n := (.inl i : PhaseVar n)) (e := 1)) + rw [hx, weightedHomogeneousComponent_monomial] + simp [monomialWeight, orderWeight, fibreWeight] + +private theorem principal_momentum_order {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@orderWeight n) 1 (momentum k n i) = + MvPolynomial.X (.inr i) := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, momentum, + presentedNormalFormLinearEquiv_generator] + have hx : MvPolynomial.X (.inr i : PhaseVar n) = + MvPolynomial.monomial + (Finsupp.single (.inr i : PhaseVar n) 1) (1 : k) := by + simpa using (MvPolynomial.X_pow_eq_monomial + (R := k) (n := (.inr i : PhaseVar n)) (e := 1)) + rw [hx, weightedHomogeneousComponent_monomial] + simp [monomialWeight, orderWeight, fibreWeight] + +private theorem principal_one_order {n : Nat} : + presentedPrincipalComponent k (@orderWeight n) 0 + (1 : PresentedWeyl k n) = 1 := by + rw [presentedPrincipalComponent, LinearMap.comp_apply, + LinearEquiv.coe_toLinearMap, presentedNormalFormLinearEquiv_one] + rw [show (1 : SymbolRing k n) = MvPolynomial.monomial 0 (1 : k) by simp, + weightedHomogeneousComponent_monomial] + simp [monomialWeight] + +private theorem principal_coordinate_pow_order {n : Nat} + (i : Fin n) (r : Nat) : + presentedPrincipalComponent k (@orderWeight n) 0 + (coordinate k n i ^ r) = MvPolynomial.X (.inl i) ^ r := by + induction r with + | zero => simpa using principal_one_order k (n := n) + | succ r ih => + rw [pow_succ, pow_succ] + rw [presentedPrincipalComponent_mul_order k + (coordinate_pow_mem_orderPiece k i r) (coordinate_mem_orderPiece k i), + ih, principal_coordinate_order] + +private theorem principal_negMomentum_pow_order {n : Nat} + (i : Fin n) (r : Nat) : + presentedPrincipalComponent k (@orderWeight n) r + ((-momentum k n i) ^ r) = (-MvPolynomial.X (.inr i)) ^ r := by + induction r with + | zero => simpa using principal_one_order k (n := n) + | succ r ih => + have hm : -momentum k n i ∈ orderPiece k n 1 := + (orderPiece k n 1).neg_mem (momentum_mem_orderPiece k i) + rw [pow_succ, pow_succ] + rw [presentedPrincipalComponent_mul_order k + (momentum_pow_mem_orderPiece k i r) hm, + ih, + map_neg, principal_momentum_order] + +private theorem principal_previous_order {n N : Nat} + (a : PresentedWeyl k n) : + presentedPrincipalComponent k (@orderWeight (n + 1)) N + (previousWeylEmbedding k n a) = + MvPolynomial.rename oldIndex + (presentedPrincipalComponent k (@orderWeight n) N a) := by + simpa [presentedCoefficientOrdered, extendPhaseExponent] using + presentedPrincipalComponent_coefficientOrdered_order k n N 0 0 a + +theorem principal_transpose_orderedMonomial_order : + ∀ (n : Nat) (a p : Fin n → Nat), + presentedPrincipalComponent k (@orderWeight n) + (monomialWeight (@orderWeight n) (phaseExponent a p)) + (transpose k n (presentedOrderedMonomial k n a p)) = + symbolTransposition k + (MvPolynomial.monomial (phaseExponent a p) (1 : k)) := by + intro n + induction n with + | zero => + intro a p + have he : phaseExponent a p = 0 := by + ext i + exact Sum.elim Fin.elim0 Fin.elim0 i + rw [he] + simp [presentedOrderedMonomial, transpose, monomialWeight, + presentedPrincipalComponent, presentedNormalFormLinearEquiv_one, + weightedHomogeneousComponent_monomial, symbolTransposition] + | succ n ih => + intro a p + let oldA : Fin n → Nat := fun i => a i.succ + let oldP : Fin n → Nat := fun i => p i.succ + let oldD := monomialWeight (@orderWeight n) (phaseExponent oldA oldP) + have hold := previousWeylEmbedding_mem_orderPiece k + (transpose_orderedMonomial_mem_orderPiece k n oldA oldP) + have hx := coordinate_pow_mem_orderPiece k + (0 : Fin (n + 1)) (a 0) + have hp := momentum_pow_mem_orderPiece k + (0 : Fin (n + 1)) (p 0) + have hxo := mul_mem_orderPiece k hx hold + rw [presentedOrderedMonomial, transpose_mul, transpose_mul, + transpose_pow, transpose_pow, + show presentedMomentum k n = momentum k (n + 1) 0 from rfl, + show presentedCoordinate k n = coordinate k (n + 1) 0 from rfl, + transpose_momentum, transpose_coordinate, + transpose_previousWeylEmbedding, + monomialWeight_phaseExponent_succ_order] + change presentedPrincipalComponent k (@orderWeight (n + 1)) + (oldD + p 0) + ((-momentum k (n + 1) 0) ^ p 0 * + (coordinate k (n + 1) 0 ^ a 0 * + previousWeylEmbedding k n + (transpose k n (presentedOrderedMonomial k n oldA oldP)))) = _ + rw [show oldD + p 0 = p 0 + (0 + oldD) by omega, + presentedPrincipalComponent_mul_order k hp hxo, + presentedPrincipalComponent_mul_order k hx hold, + principal_negMomentum_pow_order, + principal_coordinate_pow_order, + principal_previous_order, ih oldA oldP] + rw [Stafford38.WeylSymbolCompatibility.phaseMonomial_succ_decompose] + simp only [map_mul, map_pow, symbolTransposition_coordinate, + symbolTransposition_momentum, symbolTransposition_rename_oldIndex] + ring + +theorem principal_transpose_order {n N : Nat} {a : PresentedWeyl k n} + (ha : a ∈ orderPiece k n N) : + presentedPrincipalComponent k (@orderWeight n) N (transpose k n a) = + symbolTransposition k + (presentedPrincipalComponent k (@orderWeight n) N a) := by + rw [orderPiece, presentedWeightPiece_eq_span] at ha + induction ha using Submodule.span_induction with + | mem b hb => + obtain ⟨m, hm, rfl⟩ := hb + let d := monomialWeight (@orderWeight n) m + by_cases hd : d = N + · subst N + rw [presentedPBWBasis_apply] + have ht := principal_transpose_orderedMonomial_order k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + have ht' : + presentedPrincipalComponent k (@orderWeight n) d + (transpose k n + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i)))) = + symbolTransposition k (MvPolynomial.monomial m (1 : k)) := by + simpa [phaseExponent_split] using ht + have ho : + presentedPrincipalComponent k (@orderWeight n) d + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) = + MvPolynomial.monomial m (1 : k) := by + rw [← presentedPBWBasis_apply, + presentedPrincipalComponent_basis, if_pos rfl] + rw [ht', ho] + · have hdlt : d < N := lt_of_le_of_ne hm hd + have ht := transpose_orderedMonomial_mem_orderPiece k n + (fun i => m (.inl i)) (fun i => m (.inr i)) + rw [presentedPBWBasis_apply] + have ht' : transpose k n + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) ∈ + orderPiece k n d := by + simpa [phaseExponent_split] using ht + have ho : + presentedPrincipalComponent k (@orderWeight n) N + (presentedOrderedMonomial k n + (fun i => m (.inl i)) (fun i => m (.inr i))) = 0 := by + rw [← presentedPBWBasis_apply, + presentedPrincipalComponent_basis, if_neg hd] + rw [presentedPrincipalComponent_eq_zero_of_mem_of_lt k + orderWeight _ ht' hdlt, ho, map_zero] + | zero => simp + | add x y hx hy ihx ihy => simp only [transpose_add, map_add, ihx, ihy] + | smul c x hx ih => simp only [transpose_smul, map_smul, ih] + +theorem symbolTransposition_comp_self {n : Nat} : + (symbolTransposition k).comp (symbolTransposition k) = + AlgHom.id k (SymbolRing k n) := by + apply MvPolynomial.algHom_ext + intro i + cases i with + | inl i => simp + | inr i => simp + +def symbolTranspositionEquiv {n : Nat} : + SymbolRing k n ≃ₐ[k] SymbolRing k n := + AlgEquiv.ofAlgHom (symbolTransposition k) (symbolTransposition k) + (symbolTransposition_comp_self k) (symbolTransposition_comp_self k) + +/-- The associated-graded automorphism corresponding to Weyl transposition. +It is conjugate to momentum-sign substitution under the checked symbol +equivalence. -/ +def associatedGradedTransposition {n : Nat} (w : PhaseVar n → Nat) : + PresentedAssociatedGraded k w ≃ₐ[k] PresentedAssociatedGraded k w := + (presentedAssociatedGradedAlgEquiv k w).trans + ((symbolTranspositionEquiv k).trans + (presentedAssociatedGradedAlgEquiv k w).symm) + +theorem associatedGradedTransposition_mk_bernstein {n N : Nat} + (a : bernsteinPiece k n N) : + associatedGradedTransposition k bernsteinWeight + (presentedAssociatedGradedMk k bernsteinWeight a) = + presentedAssociatedGradedMk k bernsteinWeight + ⟨transpose k n a, transpose_mem_bernsteinPiece k a.property⟩ := by + change presentedWeightPiece k bernsteinWeight N at a + apply (presentedAssociatedGradedAlgEquiv k bernsteinWeight).injective + simp [associatedGradedTransposition, symbolTranspositionEquiv, + principal_transpose_bernstein k a.property] + +theorem associatedGradedTransposition_mk_order {n N : Nat} + (a : orderPiece k n N) : + associatedGradedTransposition k orderWeight + (presentedAssociatedGradedMk k orderWeight a) = + presentedAssociatedGradedMk k orderWeight + ⟨transpose k n a, transpose_mem_orderPiece k a.property⟩ := by + change presentedWeightPiece k orderWeight N at a + apply (presentedAssociatedGradedAlgEquiv k orderWeight).injective + simp [associatedGradedTransposition, symbolTranspositionEquiv, + principal_transpose_order k a.property] + +theorem principal_transpose_coordinate {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@bernsteinWeight n) 1 + (transpose k n (coordinate k n i)) = + symbolTransposition k + (presentedPrincipalComponent k (@bernsteinWeight n) 1 + (coordinate k n i)) := by + rw [transpose_coordinate] + rw [principal_coordinate_bernstein, symbolTransposition_coordinate] + +theorem principal_transpose_momentum {n : Nat} (i : Fin n) : + presentedPrincipalComponent k (@bernsteinWeight n) 1 + (transpose k n (momentum k n i)) = + symbolTransposition k + (presentedPrincipalComponent k (@bernsteinWeight n) 1 + (momentum k n i)) := by + rw [transpose_momentum] + rw [map_neg, principal_momentum_bernstein, symbolTransposition_momentum] + + +end +end Stafford38.WeylTranspositionFiltration diff --git a/LeanPool/Stafford38/Stafford38/Weyl/Universal.lean b/LeanPool/Stafford38/Stafford38/Weyl/Universal.lean new file mode 100644 index 0000000000..fb7df27030 --- /dev/null +++ b/LeanPool/Stafford38/Stafford38/Weyl/Universal.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import LeanPool.Stafford38.AlgebraicAnalysis.Ore.Associativity +import LeanPool.Stafford38.Stafford38.Ore.ScalarAlgebra +import LeanPool.Stafford38.proofs.weyl_symplectic + +/-! +# Universal property of the presented Weyl algebra + +This factors the quotient lift used by the existing symplectic maps: any +family satisfying the prescribed commutators induces a unique algebra map. +-/ + +namespace Stafford38.WeylUniversal + +open Stafford +open AlgebraicAnalysis + +noncomputable section + +variable {k ι A : Type*} [Field k] [Ring A] [Algebra k A] + +def freeWeylGeneratorMap (z : ι → A) : FreeAlgebra k ι →ₐ[k] A := + FreeAlgebra.lift k z + +theorem freeWeylGeneratorMap_respects (omega : Matrix ι ι k) (z : ι → A) + (hz : ∀ i j, Stafford.commutator (z i) (z j) = algebraMap k A (omega i j)) : + ∀ ⦃a b : FreeAlgebra k ι⦄, + freeWeylRelation omega a b → + freeWeylGeneratorMap z a = freeWeylGeneratorMap z b + | _, _, ⟨i, j, rfl, rfl⟩ => by + simp only [freeWeylGeneratorMap, map_sub, map_mul, + FreeAlgebra.lift_ι_apply, AlgHom.commutes] + exact hz i j + +/-- The algebra map induced by a family with the prescribed commutators. -/ +def freeWeylLift (omega : Matrix ι ι k) (z : ι → A) + (hz : ∀ i j, Stafford.commutator (z i) (z j) = algebraMap k A (omega i j)) : + FreeWeyl k ι omega →ₐ[k] A := + RingQuot.liftAlgHom k + ⟨freeWeylGeneratorMap z, freeWeylGeneratorMap_respects omega z hz⟩ + +@[simp] theorem freeWeylLift_generator (omega : Matrix ι ι k) (z : ι → A) + (hz : ∀ i j, Stafford.commutator (z i) (z j) = algebraMap k A (omega i j)) (i : ι) : + freeWeylLift omega z hz (freeWeylGenerator omega i) = z i := by + simp [freeWeylLift, freeWeylGenerator, freeWeylGeneratorMap, + RingQuot.liftAlgHom_mkAlgHom_apply] + +/-- Algebra maps out of the presented Weyl algebra are determined by the +canonical generators. -/ +theorem freeWeyl_algHom_ext (omega : Matrix ι ι k) + (f g : FreeWeyl k ι omega →ₐ[k] A) + (h : ∀ i, f (freeWeylGenerator omega i) = + g (freeWeylGenerator omega i)) : f = g := by + apply RingQuot.ringQuot_ext' k + apply FreeAlgebra.hom_ext + funext i + exact h i + + +end +end Stafford38.WeylUniversal diff --git a/LeanPool/Stafford38/proofs/stafford38_reduction.lean b/LeanPool/Stafford38/proofs/stafford38_reduction.lean new file mode 100644 index 0000000000..f4e7a3dd37 --- /dev/null +++ b/LeanPool/Stafford38/proofs/stafford38_reduction.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Christopher Albert. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christopher Albert +-/ + +import Mathlib + +/-! +# Transport of Stafford certificates + +The right-ideal certificate is `1 = e * R + F * e * S`. +This module supplies the generic conditional reduction from monicization and +an exponent hypothesis, together with transport through algebra automorphisms +and nonzero scalars. These conditional interfaces are retained for current +imports; the unconditional theorem is proved in `Stafford38.FoundationClosure`. +-/ + +namespace Stafford +namespace Reduction + +variable {k A : Type*} [Field k] [Ring A] [Algebra k A] + +/-- The commutator `ad Y u = Y * u - u * Y`. -/ +def ad (Y u : A) : A := Y * u - u * Y + +/-- Stafford 3.8 for a single element, in written operator order. -/ +def Stafford38 (e : A) : Prop := ∃ F R S : A, (1 : A) = e * R + F * e * S + +/-- The monic right-coefficient presentation `X ^ N + ∑_{i